Regrouper des onglets selon leur nom [VBA]

nat54 · 29 Décembre 2009

Bonjour,

Je vais essayer de faire clair mais cela n'est pas simple

--> un répertoire où j'exporte des fichiers excel en provenance de BO
....\Exports_BO_provisoires

10 fichiers tous présentés de la même manière à savoir 31 onglets, un onglet par code pôle

L'objectif est de créer 31 fichiers (un par pôle) avec 10 onglets
les onglets sont "reconnaissables" car ils contiennent le code pole

je l'avais fait pour 4 avec votre aide (mais je ne trouve plus le fil), je voulais le faire pour 10 fichiers
a priori c'était facile mais je bloque

Le code actuel
Le pb est en rouge, excel me dit
"variable objet ou variable de bloc With non définie"

Code:

Sub Creer_un_fichier_par_pole()
Dim Fn_BAR_incoherente_vs_BAT As String, Fn_Badg_fac_decp_horaire As String, Fn_BAR_inf_BAT As String, Fn_CA_negatif As String, Fn_Agent_jour_BAT_diff_7 As String, Fn_Agent_nuit_BAT_diff_6h30 As String, Fn_Param_BAR As String, Fn_RC_inf_35 As String, Fn_RC_sup_100 As String, Fn_RTT_negatif As String, wbk_BAR_incoherente_vs_BAT As Workbook, wbk_Badg_fac_decp_horaire As Workbook, wbk_BAR_inf_BAT As Workbook, wbk_CA_negatif As Workbook, wbk_Agent_jour_BAT_diff_7 As Workbook, wbk_Agent_nuit_BAT_diff_6h30 As Workbook, wbk_Param_BAR As Workbook, wbk_RC_inf_35 As Workbook, wbk_RC_sup_100 As Workbook, wbk_RTT_negatif As Workbook, newWbk As Workbook, extractFolderPath As String, sht_BAR_incoherente_vs_BAT As Worksheet, sht_Badg_fac_decp_horaire As Worksheet, sht_BAR_inf_BAT As Worksheet, sht_CA_negatif As Worksheet, sht_Agent_jour_BAT_diff_7 As Worksheet, sht_Agent_nuit_BAT_diff_6h30 As Worksheet, sht_Param_BAR As Worksheet, sht_RC_inf_35 As Worksheet, sht_RC_sup_100 As Worksheet, sht_RTT_negatif As Worksheet, Code
Application.DisplayAlerts = False
'récupérer les "fichier sources" et le "dossier destination"
Fn_BAR_incoherente_vs_BAT = Application.GetOpenFilename(filefilter:="Fichiers Excel, *.xls; *.xlsx; *.xlsm", Title:="Sélectionnez le fichier "" POLE_BAR_incoherente_vs_BAT""")
Fn_Badg_fac_decp_horaire = Application.GetOpenFilename(filefilter:="Fichiers Excel, *.xls; *.xlsx; *.xlsm", Title:="Sélectionnez le fichier "" POLE_pb_badg_fac_pr_decpte_horaire""")
Fn_BAR_inf_BAT = Application.GetOpenFilename(filefilter:="Fichiers Excel, *.xls; *.xlsx; *.xlsm", Title:="Sélectionnez le fichier "" POLE_pb_BAR_inf_BAT""")
Fn_CA_negatif = Application.GetOpenFilename(filefilter:="Fichiers Excel, *.xls; *.xlsx; *.xlsm", Title:="Sélectionnez le fichier "" POLE_pb_CA_negatif""")
Fn_Agent_jour_BAT_diff_7 = Application.GetOpenFilename(filefilter:="Fichiers Excel, *.xls; *.xlsx; *.xlsm", Title:="Sélectionnez le fichier "" POLE_pb_jour_BATp_diff_7_par_pole""")
Fn_Agent_nuit_BAT_diff_6h30 = Application.GetOpenFilename(filefilter:="Fichiers Excel, *.xls; *.xlsx; *.xlsm", Title:="Sélectionnez le fichier "" POLE_pb_nuit_BATp_diff_6h30""")
Fn_Param_BAR = Application.GetOpenFilename(filefilter:="Fichiers Excel, *.xls; *.xlsx; *.xlsm", Title:="Sélectionnez le fichier "" POLE_pb_PARAM-BAR""")
Fn_RC_inf_35 = Application.GetOpenFilename(filefilter:="Fichiers Excel, *.xls; *.xlsx; *.xlsm", Title:="Sélectionnez le fichier "" POLE_pb_RC_inf_35""")
Fn_RC_sup_100 = Application.GetOpenFilename(filefilter:="Fichiers Excel, *.xls; *.xlsx; *.xlsm", Title:="Sélectionnez le fichier "" POLE_pb_RC_sup_100""")
Fn_RTT_negatif = Application.GetOpenFilename(filefilter:="Fichiers Excel, *.xls; *.xlsx; *.xlsm", Title:="Sélectionnez le fichier "" POLE_pb_RTT_negatif""")
extractFolderPath = "I:\DRH\EFFECTIF\BO\Gestor\Fichiers_par_pole"

'ouvrir les "fichier sources"
Set wbk_BAR_incoherente_vs_BAT = Application.Workbooks.Open(Filename:=Fn_BAR_incoherente_vs_BAT, ReadOnly:=True)
Set wbk_Badg_fac_decp_horaire = Application.Workbooks.Open(Filename:=Fn_Badg_fac_decp_horaire, ReadOnly:=True)
Set wbk_BAR_inf_BAT = Application.Workbooks.Open(Filename:=Fn_BAR_inf_BAT, ReadOnly:=True)
Set wbk_CA_negatif = Application.Workbooks.Open(Filename:=Fn_CA_negatif, ReadOnly:=True)
Set wbk_Agent_jour_BAT_diff_7 = Application.Workbooks.Open(Filename:=Fn_Agent_jour_BAT_diff_7, ReadOnly:=True)
Set wbk_Agent_nuit_BAT_diff_6h30 = Application.Workbooks.Open(Filename:=Fn_Agent_nuit_BAT_diff_6h30, ReadOnly:=True)
Set wbk_Param_BAR = Application.Workbooks.Open(Filename:=Fn_Param_BAR, ReadOnly:=True)
Set wbk_RC_inf_35 = Application.Workbooks.Open(Filename:=Fn_RC_inf_35, ReadOnly:=True)
Set wbk_RC_sup_100 = Application.Workbooks.Open(Filename:=Fn_RC_sup_100, ReadOnly:=True)
Set wbk_RTT_negatif = Application.Workbooks.Open(Filename:=Fn_RTT_negatif, ReadOnly:=True)
 
    'boucler sur les onglets du fichier BAR_incoherente_BAT
    For Each sht_BAR_incoherente_vs_BAT In wbk_BAR_incoherente_vs_BAT.Sheets
        'si le nom de l'onglet analysé contient le "code pole", alors on copie la feuille dans le nouveau classeur
        If InStr(sht_BAR_incoherente_vs_BAT.Name, CodePole) > 0 [COLOR=red]Then sht_BAR_incoherente_vs_BAT.Copy after:=newWbk.Sheets(newWbk.Sheets.Count)[/COLOR]
    Next sht_BAR_incoherente_vs_BAT
        'boucler sur les onglets du fichier wbk_Badg_fac_decp_horaire
    For Each sht_Badg_fac_decp_horaire In wbk_Badg_fac_decp_horaire.Sheets
        'si le nom de l'onglet analysé contient le "code pole", alors on copie la feuille dans le nouveau classeur
        If InStr(sht_Badg_fac_decp_horaire.Name, CodePole) > 0 Then sht_Badg_fac_decp_horaire.Copy after:=newWbk.Sheets(newWbk.Sheets.Count)
    Next sht_Badg_fac_decp_horaire
    'boucler sur les onglets du fichier wbk_BAR_inf_BAT
    For Each sht_BAR_inf_BAT In wbk_BAR_inf_BAT.Sheets
        'si le nom de l'onglet analysé contient le "code pole", alors on copie la feuille dans le nouveau classeur
        If InStr(sht_BAR_inf_BAT.Name, CodePole) > 0 Then sht_BAR_inf_BAT.Copy after:=newWbk.Sheets(newWbk.Sheets.Count)
            Next sht_BAR_inf_BAT
    'boucler sur les onglets du fichier wbk_CA_negatif
    For Each sht_CA_negatif In wbk_CA_negatif.Sheets
        'si le nom de l'onglet analysé contient le "code pole", alors on copie la feuille dans le nouveau classeur
        If InStr(sht_CA_negatif.Name, CodePole) > 0 Then sht_CA_negatif.Copy after:=newWbk.Sheets(newWbk.Sheets.Count)
    Next sht_CA_negatif
    'boucler sur les onglets du fichier wbk_Agent_jour_BAT_diff_7
    For Each sht_Agent_jour_BAT_diff_7 In wbk_Agent_jour_BAT_diff_7.Sheets
        'si le nom de l'onglet analysé contient le "code pole", alors on copie la feuille dans le nouveau classeur
        If InStr(sht_Agent_jour_BAT_diff_7.Name, CodePole) > 0 Then sht_Agent_jour_BAT_diff_7.Copy after:=newWbk.Sheets(newWbk.Sheets.Count)
    Next sht_Agent_jour_BAT_diff_7
    'boucler sur les onglets du fichier wbk_Agent_nuit_BAT_diff_6h30
    For Each sht_Agent_nuit_BAT_diff_6h30 In wbk_Agent_nuit_BAT_diff_6h30.Sheets
        'si le nom de l'onglet analysé contient le "code pole", alors on copie la feuille dans le nouveau classeur
        If InStr(sht_Agent_nuit_BAT_diff_6h30.Name, CodePole) > 0 Then sht_Agent_nuit_BAT_diff_6h30.Copy after:=newWbk.Sheets(newWbk.Sheets.Count)
    Next sht_Agent_nuit_BAT_diff_6h30
    'boucler sur les onglets du fichier wbk_Param_BAR
    For Each sht_Param_BAR In wbk_Param_BAR.Sheets
        'si le nom de l'onglet analysé contient le "code pole", alors on copie la feuille dans le nouveau classeur
        If InStr(sht_Param_BAR.Name, CodePole) > 0 Then sht_Param_BAR.Copy after:=newWbk.Sheets(newWbk.Sheets.Count)
    Next sht_Param_BAR
    'boucler sur les onglets du fichier wbk_RC_inf_35
    For Each sht_RC_inf_35 In wbk_RC_inf_35.Sheets
        'si le nom de l'onglet analysé contient le "code pole", alors on copie la feuille dans le nouveau classeur
        If InStr(wbk_RC_inf_35.Name, CodePole) > 0 Then wbk_RC_inf_35.Copy after:=newWbk.Sheets(newWbk.Sheets.Count)
    Next sht_RC_inf_35
    'boucler sur les onglets du fichier wbk_RC_sup_100
    For Each sht_RC_sup_100 In wbk_RC_sup_100.Sheets
        'si le nom de l'onglet analysé contient le "code pole", alors on copie la feuille dans le nouveau classeur
        If InStr(sht_RC_sup_100.Name, CodePole) > 0 Then sht_RC_sup_100.Copy after:=newWbk.Sheets(newWbk.Sheets.Count)
    Next sht_RC_sup_100
    'boucler sur les onglets du fichier wbk_RTT_negatif
    For Each sht_RTT_negatif In wbk_RTT_negatif.Sheets
        'si le nom de l'onglet analysé contient le "code pole", alors on copie la feuille dans le nouveau classeur
        If InStr(sht_RTT_negatif.Name, CodePole) > 0 Then sht_RTT_negatif.Copy after:=newWbk.Sheets(newWbk.Sheets.Count)
    Next sht_RTT_negatif
    
 
    'sauvegarder et fermer le classeur spécifique à ce pole
    newWbk.SaveAs extractFolderPath & "\ANOMALIES_" & CodePole
    newWbk.Close
 
'fermer les classeurs
wbk_BAR_incoherente_vs_BAT.Close: Set wbk_BAR_incoherente_vs_BAT = Nothing
wbk_Badg_fac_decp_horaire.Close: Set wbk_Badg_fac_decp_horaire = Nothing
wbk_BAR_inf_BAT.Close: Set wbk_BAR_inf_BAT = Nothing
wbk_CA_negatif.Close: Set wbk_CA_negatif = Nothing
wbk_Agent_jour_BAT_diff_7.Close: Set wbk_Agent_jour_BAT = Nothing
wbk_Agent_nuit_BAT_diff_6h30.Close: Set wbk_Agent_nuit_BAT_diff_6h30 = Nothing
wbk_Param_BAR.Close: Set wbk_Param_BAR = Nothing
wbk_RC_inf_35.Close: Set wbk_RC_inf_35 = Nothing
wbk_RC_sup_100: Set wbk_RC_sup_100 = Nothing
wbk_RTT_negatif.Close: Set wbk_RTT_negatif = Nothing
Set newWbk = Nothing
Application.DisplayAlerts = True
End Sub

merci d'avance

Pierrot93 · 30 Décembre 2009

Re : Regrouper des onglets selon leur nom [VBA]

Re,

oui Nat, mais la méthode "add" que je préconisais alors, ne s'applique pas à ce cas... Car je suppose que les données de chaque onglets copiés sont différentes...

Pierrot93 · 30 Décembre 2009

Re : Regrouper des onglets selon leur nom [VBA]

Re

remarque la solution serait peut être de créée une nouvelle feuille dans le nouveau classeur, et faire un copier / coller de toutes les cellules.... A voir...

pierrejean · 30 Décembre 2009

Re : Regrouper des onglets selon leur nom [VBA]

Re

Je pense egalement a un probleme de memoire
Je viens de tester apres avoir mis un

Code:

Application.CutCopyMode = False

apres toutes les methodes .Copy
et le plantage d'Excel ne survient plus qu'apres le 29eme fichier

NB: Le plantage de Windows n'etait vraisemblablement qu'une coincidence

nat54 · 30 Décembre 2009

Re : Regrouper des onglets selon leur nom [VBA]

Pierrot93 à dit:
Re

remarque la solution serait peut être de créée une nouvelle feuille dans le nouveau classeur, et faire un copier / coller de toutes les cellules.... A voir...

je ne suis pas sûre de comprendre...

Pierrot93 · 30 Décembre 2009

Re : Regrouper des onglets selon leur nom [VBA]

Re

je voulais dire, plutôt que de copier les onglets, copier les cellules vers une nouvelle feuille du nouveau classeur....

Pierrot93 · 30 Décembre 2009

Re : Regrouper des onglets selon leur nom [VBA]

Re,

je viens de trouver ce fil :

La copie d'une feuille de calcul par programmation provoque l'erreur d'exécution 1004 dans Excel

A priori, avec un enregistrement du nouveau classeur après chaque copie, le problème devrait être résolu, je viens de tester chez moi et le code ci-dessous est passé sans aucune erreur.... En espérant qu'il en soit de même chez vous....

Code:

Option Explicit
Sub Creer_un_fichier_par_pole()
Dim Fn_BAR_incoherente_vs_BAT As String, Fn_Badg_fac_decp_horaire As String, Fn_BAR_inf_BAT As String, Fn_CA_negatif As String, Fn_Agent_jour_BAT_diff_7 As String, Fn_Agent_nuit_BAT_diff_6h30 As String, Fn_Param_BAR As String, Fn_RC_inf_35 As String, Fn_RC_sup_100 As String, Fn_RTT_negatif As String, wbk_BAR_incoherente_vs_BAT As Workbook, wbk_Badg_fac_decp_horaire As Workbook, wbk_BAR_inf_BAT As Workbook, wbk_CA_negatif As Workbook, wbk_Agent_jour_BAT_diff_7 As Workbook, wbk_Agent_nuit_BAT_diff_6h30 As Workbook, wbk_Param_BAR As Workbook, wbk_RC_inf_35 As Workbook, wbk_RC_sup_100 As Workbook, wbk_RTT_negatif As Workbook, newWbk As Workbook, extractFolderPath As String, sht_BAR_incoherente_vs_BAT As Worksheet, sht_Badg_fac_decp_horaire As Worksheet, sht_BAR_inf_BAT As Worksheet, sht_CA_negatif As Worksheet, sht_Agent_jour_BAT_diff_7 As Worksheet, sht_Agent_nuit_BAT_diff_6h30 As Worksheet, sht_Param_BAR As Worksheet, sht_RC_inf_35 As Worksheet, sht_RC_sup_100 As Worksheet, sht_RTT_negatif As Worksheet, Code
Dim CodePole As String
Application.DisplayAlerts = False
'récupérer les "fichier sources" et le "dossier destination"
Fn_BAR_incoherente_vs_BAT = Application.GetOpenFilename(filefilter:="Fichiers Excel, *.xls; *.xlsx; *.xlsm", Title:="Sélectionnez le fichier "" POLE_BAR_incoherente_vs_BAT""")
Fn_Badg_fac_decp_horaire = Application.GetOpenFilename(filefilter:="Fichiers Excel, *.xls; *.xlsx; *.xlsm", Title:="Sélectionnez le fichier "" POLE_pb_badg_fac_pr_decpte_horaire""")
Fn_BAR_inf_BAT = Application.GetOpenFilename(filefilter:="Fichiers Excel, *.xls; *.xlsx; *.xlsm", Title:="Sélectionnez le fichier "" POLE_pb_BAR_inf_BAT""")
Fn_CA_negatif = Application.GetOpenFilename(filefilter:="Fichiers Excel, *.xls; *.xlsx; *.xlsm", Title:="Sélectionnez le fichier "" POLE_pb_CA_negatif""")
Fn_Agent_jour_BAT_diff_7 = Application.GetOpenFilename(filefilter:="Fichiers Excel, *.xls; *.xlsx; *.xlsm", Title:="Sélectionnez le fichier "" POLE_pb_jour_BATp_diff_7_par_pole""")
Fn_Agent_nuit_BAT_diff_6h30 = Application.GetOpenFilename(filefilter:="Fichiers Excel, *.xls; *.xlsx; *.xlsm", Title:="Sélectionnez le fichier "" POLE_pb_nuit_BATp_diff_6h30""")
Fn_Param_BAR = Application.GetOpenFilename(filefilter:="Fichiers Excel, *.xls; *.xlsx; *.xlsm", Title:="Sélectionnez le fichier "" POLE_pb_PARAM-BAR""")
Fn_RC_inf_35 = Application.GetOpenFilename(filefilter:="Fichiers Excel, *.xls; *.xlsx; *.xlsm", Title:="Sélectionnez le fichier "" POLE_pb_RC_inf_35""")
Fn_RC_sup_100 = Application.GetOpenFilename(filefilter:="Fichiers Excel, *.xls; *.xlsx; *.xlsm", Title:="Sélectionnez le fichier "" POLE_pb_RC_sup_100""")
Fn_RTT_negatif = Application.GetOpenFilename(filefilter:="Fichiers Excel, *.xls; *.xlsx; *.xlsm", Title:="Sélectionnez le fichier "" POLE_pb_RTT_negatif""")

extractFolderPath = "I:\DRH\EFFECTIF\BO\Gestor\Fichiers_par_pole"

'ouvrir les "fichier sources"
Set wbk_BAR_incoherente_vs_BAT = Application.Workbooks.Open(Filename:=Fn_BAR_incoherente_vs_BAT, ReadOnly:=True)
Set wbk_Badg_fac_decp_horaire = Application.Workbooks.Open(Filename:=Fn_Badg_fac_decp_horaire, ReadOnly:=True)
Set wbk_BAR_inf_BAT = Application.Workbooks.Open(Filename:=Fn_BAR_inf_BAT, ReadOnly:=True)
Set wbk_CA_negatif = Application.Workbooks.Open(Filename:=Fn_CA_negatif, ReadOnly:=True)
Set wbk_Agent_jour_BAT_diff_7 = Application.Workbooks.Open(Filename:=Fn_Agent_jour_BAT_diff_7, ReadOnly:=True)
Set wbk_Agent_nuit_BAT_diff_6h30 = Application.Workbooks.Open(Filename:=Fn_Agent_nuit_BAT_diff_6h30, ReadOnly:=True)
Set wbk_Param_BAR = Application.Workbooks.Open(Filename:=Fn_Param_BAR, ReadOnly:=True)
Set wbk_RC_inf_35 = Application.Workbooks.Open(Filename:=Fn_RC_inf_35, ReadOnly:=True)
Set wbk_RC_sup_100 = Application.Workbooks.Open(Filename:=Fn_RC_sup_100, ReadOnly:=True)
Set wbk_RTT_negatif = Application.Workbooks.Open(Filename:=Fn_RTT_negatif, ReadOnly:=True)

Application.ScreenUpdating = False

'boucler sur les onglets du fichier RC inf 35
For Each sht_RC_inf_35 In wbk_RC_inf_35.Sheets
    
    'récupérer le code pole de l'"onglet RC" analysé
    CodePole = "*" & Trim(Replace(sht_RC_inf_35.Name, "PB RC", "")) & "*"
    
    'créer un classeur spécifique à ce pole contenant une seule feuille
    Set newWbk = Application.Workbooks.Add(xlWBATWorksheet)
    
    'copier l'onglet RC analysé après le dernier onglet du nouveau classeur
    sht_RC_inf_35.Copy after:=newWbk.Sheets(newWbk.Sheets.Count)
    
    newWbk.Sheets(newWbk.Sheets.Count).Name = newWbk.Sheets(newWbk.Sheets.Count).Name & "inf35"
    
    'enregistrement du nouveau classeur
    newWbk.SaveAs extractFolderPath & "\ANOMALIES_" & Replace(CodePole, "*", "")

    'boucler sur les onglets du fichier BAR_incoherente_BAT
    For Each sht_BAR_incoherente_vs_BAT In wbk_BAR_incoherente_vs_BAT.Sheets
        'si le nom de l'onglet analysé contient le "code pole", alors on copie la feuille dans le nouveau classeur
        If sht_BAR_incoherente_vs_BAT.Name Like CodePole Then sht_BAR_incoherente_vs_BAT.Copy after:=newWbk.Sheets(newWbk.Sheets.Count): Exit For
    Next sht_BAR_incoherente_vs_BAT
    'enregistrement
    newWbk.Save
    
    'boucler sur les onglets du fichier wbk_Badg_fac_decp_horaire
    For Each sht_Badg_fac_decp_horaire In wbk_Badg_fac_decp_horaire.Sheets
        'si le nom de l'onglet analysé contient le "code pole", alors on copie la feuille dans le nouveau classeur
        If sht_Badg_fac_decp_horaire.Name Like CodePole Then sht_Badg_fac_decp_horaire.Copy after:=newWbk.Sheets(newWbk.Sheets.Count): Exit For
    Next sht_Badg_fac_decp_horaire
    'enregistrement
    newWbk.Save

    'boucler sur les onglets du fichier wbk_BAR_inf_BAT
    For Each sht_BAR_inf_BAT In wbk_BAR_inf_BAT.Sheets
        'si le nom de l'onglet analysé contient le "code pole", alors on copie la feuille dans le nouveau classeur
        If sht_BAR_inf_BAT.Name Like CodePole Then sht_BAR_inf_BAT.Copy after:=newWbk.Sheets(newWbk.Sheets.Count): Exit For
    Next sht_BAR_inf_BAT
    'enregistrement
    newWbk.Save

    'boucler sur les onglets du fichier wbk_CA_negatif
    For Each sht_CA_negatif In wbk_CA_negatif.Sheets
        'si le nom de l'onglet analysé contient le "code pole", alors on copie la feuille dans le nouveau classeur
        If sht_CA_negatif.Name Like CodePole Then sht_CA_negatif.Copy after:=newWbk.Sheets(newWbk.Sheets.Count): Exit For
    Next sht_CA_negatif
    'enregistrement
    newWbk.Save

    'boucler sur les onglets du fichier wbk_Agent_jour_BAT_diff_7
    For Each sht_Agent_jour_BAT_diff_7 In wbk_Agent_jour_BAT_diff_7.Sheets
        'si le nom de l'onglet analysé contient le "code pole", alors on copie la feuille dans le nouveau classeur
        If sht_Agent_jour_BAT_diff_7.Name Like CodePole Then sht_Agent_jour_BAT_diff_7.Copy after:=newWbk.Sheets(newWbk.Sheets.Count): Exit For
    Next sht_Agent_jour_BAT_diff_7
    'enregistrement
    newWbk.Save

    'boucler sur les onglets du fichier wbk_Agent_nuit_BAT_diff_6h30
    For Each sht_Agent_nuit_BAT_diff_6h30 In wbk_Agent_nuit_BAT_diff_6h30.Sheets
        'si le nom de l'onglet analysé contient le "code pole", alors on copie la feuille dans le nouveau classeur
        If sht_Agent_nuit_BAT_diff_6h30.Name Like CodePole Then sht_Agent_nuit_BAT_diff_6h30.Copy after:=newWbk.Sheets(newWbk.Sheets.Count): Exit For
    Next sht_Agent_nuit_BAT_diff_6h30
    'enregistrement
    newWbk.Save

    'boucler sur les onglets du fichier wbk_Param_BAR
    For Each sht_Param_BAR In wbk_Param_BAR.Sheets
        'si le nom de l'onglet analysé contient le "code pole", alors on copie la feuille dans le nouveau classeur
        If sht_Param_BAR.Name Like CodePole Then sht_Param_BAR.Copy after:=newWbk.Sheets(newWbk.Sheets.Count): Exit For
    Next sht_Param_BAR
    'enregistrement
    newWbk.Save
  
    'boucler sur les onglets du fichier wbk_RC_sup_100
    For Each sht_RC_sup_100 In wbk_RC_sup_100.Sheets
        'si le nom de l'onglet analysé contient le "code pole", alors on copie la feuille dans le nouveau classeur
        If sht_RC_sup_100.Name Like CodePole Then sht_RC_sup_100.Copy after:=newWbk.Sheets(newWbk.Sheets.Count): Exit For
    Next sht_RC_sup_100
    'enregistrement
    newWbk.Save

    'boucler sur les onglets du fichier wbk_RTT_negatif
    For Each sht_RTT_negatif In wbk_RTT_negatif.Sheets
        'si le nom de l'onglet analysé contient le "code pole", alors on copie la feuille dans le nouveau classeur
        If sht_RTT_negatif.Name Like CodePole Then sht_RTT_negatif.Copy after:=newWbk.Sheets(newWbk.Sheets.Count): Exit For
    Next sht_RTT_negatif
    
    'sauvegarder et fermer le classeur spécifique à ce pole
    newWbk.Close True
Next sht_RC_inf_35

'fermer les classeurs
wbk_BAR_incoherente_vs_BAT.Close: Set wbk_BAR_incoherente_vs_BAT = Nothing
wbk_Badg_fac_decp_horaire.Close: Set wbk_Badg_fac_decp_horaire = Nothing
wbk_BAR_inf_BAT.Close: Set wbk_BAR_inf_BAT = Nothing
wbk_CA_negatif.Close: Set wbk_CA_negatif = Nothing
wbk_Agent_jour_BAT_diff_7.Close: Set wbk_Agent_jour_BAT_diff_7 = Nothing
wbk_Agent_nuit_BAT_diff_6h30.Close: Set wbk_Agent_nuit_BAT_diff_6h30 = Nothing
wbk_Param_BAR.Close: Set wbk_Param_BAR = Nothing
wbk_RC_inf_35.Close: Set wbk_RC_inf_35 = Nothing
wbk_RC_sup_100.Close: Set wbk_RC_sup_100 = Nothing
wbk_RTT_negatif.Close: Set wbk_RTT_negatif = Nothing

Set newWbk = Nothing

Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

nat54 · 30 Décembre 2009

Re : Regrouper des onglets selon leur nom [VBA]

j'avais bon espoir vu que ca tournait ..

et paf microsoft excel a rencontré une erreur et doit fermer

direction le répertoire ; 26 fichiers crées

ah la la ....

pierrejean · 30 Décembre 2009

Re : Regrouper des onglets selon leur nom [VBA]

Re

Une solution de secours (que l'on pourra peaufiner ensuite)
dans le fichier procedure la macro separe cree 2 fichiers POLE_pb_RC_inf_35_a et b
ensuite 2 fichiers (procedure_a et procedure_b ) les traitent

Ps: readapter extract......

nat54 · 30 Décembre 2009

Re : Regrouper des onglets selon leur nom [VBA]

je ne comprends pas trop le principe .. du coup, je lance quoi en 1er ??

pierrejean · 30 Décembre 2009

Re : Regrouper des onglets selon leur nom [VBA]

Re

Normal : J'ai terminé a la va vite !!
je reverifie parce que malheureusement j'ai un peu tripoté tout ca et je reviens

Le principe est le suivant:
la macro separe (située en fait dans procedure_a) coupe Pole_pb_RC_inf_35.xls en 2
Pole_pb_RC_inf_35_a.xls
Pole_pb_RC_inf_35_b.xls avec chacun la moitié des feuilles
Pole_pb_RC_inf_35_a.xls est ensuite traité par procedure_a Sub Creer_un_fichier_par_pole
Pole_pb_RC_inf_35_b.xls est ensuite traité par procedure_b Sub Creer_un_fichier_par_pole

Toutefois ,si cela a fonctionné au moins une fois je suis encore retombé dans un plantage d'Excel
J'essaie a l'heure actuelle diverses procedures genre tout fermer et recommencer

nat54 · 30 Décembre 2009

Re : Regrouper des onglets selon leur nom [VBA]

Alors ca crée bien 31 fichiers

mais avec seulement 3 onglets par fichier au lieu des 10

pierrejean · 30 Décembre 2009

Re : Regrouper des onglets selon leur nom [VBA]

re

j'ai changé mon fusil d'epaule et créé ma procedure a moi

Elle est un peu longue (85 secondes chez moi) mais elle ne plante pas Excel et sort bien 31 fichiers de 10 feuilles

Par ailleurs je ne fait pas partie de ceux pour qui l'option explicit est une necessité mais rien ne t'empeche de l'ajouter ( avec les declarations de variables qui vont avec)

PS: Le chemin est adapter bien sur (je te fais confiance )

nat54 · 30 Décembre 2009

Re : Regrouper des onglets selon leur nom [VBA]

Merci de ton investissement, je teste ça demain au boulot

edit : j'ouvre l'éditeur vba et là wow quel changement, je vais essayer de comprendre !

nat54 · 30 Décembre 2009

Re : Regrouper des onglets selon leur nom [VBA]

Code:

Sub Creer_un_fichier_par_pole()
'debut = Timer
Application.ScreenUpdating = False
fichiers = Array("POLE_BAR_incoherente_vs_BAT", "POLE_pb_badg_fac_pr_decpte_horaire", "POLE_pb_BAR_inf_BAT", "POLE_pb_CA_negatif", "POLE_pb_jour_BATp_diff_7_par_pole", "POLE_pb_nuit_BATp_diff_6h30", "POLE_pb_PARAM-BAR", "POLE_pb_RC_sup_100", "POLE_pb_RTT_negatif")
Dim wbinf As Workbook
[COLOR=Red]chemin = ThisWorkbook.Path >> de quel workbook on parle là ?[/COLOR]
Set wbinf = Workbooks.Open(chemin & "\POLE_pb_RC_inf_35.xls")
For Each sh In wbinf.Sheets
  codePole = Replace(sh.Name, "PB RC ", "")
  SonNom = "ANOMALIES_" & codePole & ".xls"
[COLOR=Red]  Workbooks.Add (xlWBATWorksheet)[/COLOR] [COLOR=Red]>> là je ne comprends pas[/COLOR]
  ActiveWorkbook.SaveAs (chemin & "\Fichiers_par_pole\" & SonNom)
  sh.Cells.Copy Destination:=Workbooks(SonNom).Sheets(1).Cells
  Workbooks(SonNom).Sheets(1).Name = sh.Name & " " & "inf35"
  [COLOR=Red]For n = LBound(fichiers) To UBound(fichiers) >> là c'est du chinois[/COLOR] :D
    Workbooks.Open (chemin & "\" & fichiers(n) & ".xls")
    With Workbooks(fichiers(n) & ".xls")
      For m = 1 To .Sheets.Count
         If InStr(.Sheets(m).Name, codePole) <> 0 Then
            Workbooks(SonNom).Sheets.Add.Name = .Sheets(m).Name
            .Sheets(m).Cells.Copy Destination:=Workbooks(SonNom).Sheets(.Sheets(m).Name).Cells
         End If
      Next m
    End With
  Next n
  Workbooks(SonNom).Save
  Workbooks(SonNom).Close
Next sh
For n = LBound(fichiers) To UBound(fichiers)
  Workbooks(fichiers(n) & ".xls").Close
Next n
wbinf.Close
Application.ScreenUpdating = True
'MsgBox (Timer - debut)
End Sub

mon code je le comprenais mieux mais bon ...

pierrejean · 31 Décembre 2009

Re : Regrouper des onglets selon leur nom [VBA]

Re

Le code commenté

Code:

Sub Creer_un_fichier_par_pole()
'debut = Timer
Application.ScreenUpdating = False
'mise sous forme de tableau des noms des fichiers a explorer
fichiers = Array("POLE_BAR_incoherente_vs_BAT", "POLE_pb_badg_fac_pr_decpte_horaire", "POLE_pb_BAR_inf_BAT", "POLE_pb_CA_negatif", "POLE_pb_jour_BATp_diff_7_par_pole", "POLE_pb_nuit_BATp_diff_6h30", "POLE_pb_PARAM-BAR", "POLE_pb_RC_sup_100", "POLE_pb_RTT_negatif")
Dim wbinf As Workbook
'Ce chemin est le nom du repertoire ou se trouve MaProcedure ainsi que les fichiers
chemin = ThisWorkbook.Path
'Ouvrir le fichier POLE_pb_RC_inf_35.xls (supposé etre dans le même repertoire que MaProcedure
Set wbinf = Workbooks.Open(chemin & "\POLE_pb_RC_inf_35.xls")
'balayage de chaque feuille de Wbinf
For Each sh In wbinf.Sheets
'definition de code pole (noter le dernier espace "De PB RC "
  codePole = Replace(sh.Name, "PB RC ", "")
 'definir le nom du fichier a creer
  SonNom = "ANOMALIES_" & codePole & ".xls"
 'creer un fichier (avec une seule feuille :xlWBATWorksheet
  Workbooks.Add (xlWBATWorksheet)
 'le nommer
  ActiveWorkbook.SaveAs (chemin & "\Fichiers_par_pole\" & SonNom)
  'copier dans la 1ere feuille la feuille de wbinf
  sh.Cells.Copy Destination:=Workbooks(SonNom).Sheets(1).Cells
  'la nommer
  Workbooks(SonNom).Sheets(1).Name = sh.Name & " " & "inf35"
  'pour n= debut du tableau fichiers a fin du tableau fichiers
  For n = LBound(fichiers) To UBound(fichiers)
  'Ouvir le fichier dont le nom est a la nieme place dans l'Array fichiers
    Workbooks.Open (chemin & "\" & fichiers(n) & ".xls")
    With Workbooks(fichiers(n) & ".xls")
    'pour chacune des feuilles de ce fichier
      For m = 1 To .Sheets.Count
    'si codePole est inclus dans le nom de la feuille
         If InStr(.Sheets(m).Name, codePole) <> 0 Then
    'ajouter une feuille au fichier créé
            Workbooks(SonNom).Sheets.Add.Name = .Sheets(m).Name
    'y mettre les cellules de la feuille examinée
            .Sheets(m).Cells.Copy Destination:=Workbooks(SonNom).Sheets(.Sheets(m).Name).Cells
         End If
      Next m
    End With
  Next n
  'Sauver le fichier créé
  Workbooks(SonNom).Save
  'fermer le fichier examiné
  Workbooks(SonNom).Close
Next sh
'fermer tous les fichiers
For n = LBound(fichiers) To UBound(fichiers)
  Workbooks(fichiers(n) & ".xls").Close
Next n
wbinf.Close
Application.ScreenUpdating = True
'MsgBox (Timer - debut)
End Sub

Si tu as des problemes avec les repertoires reviens en precisant les chemins respectifs des fichiers

Regrouper des onglets selon leur nom [VBA]

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

Pièces jointes

XLDnaute Barbatruc

XLDnaute Barbatruc

Pièces jointes

XLDnaute Barbatruc

XLDnaute Barbatruc

Pièces jointes

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

Discussions similaires

Partager cette page

Statistiques des forums