Création automatique Classeurs (Sources, feuilles classeurs existants)

Bonjour,

Je dispose d'un classeur avec plusieurs feuilles dont des feuilles portant le nom des mois de l'année. Dans ces mois de l'année, j'ai un planning par personnes, je souhaiterais mettre dans un seul fichier excel tout le planning par mois d'une personne.

1-Parmi les feuilles, il y a la liste des personnes. Cela me permet de faire ma boucle et mon filtre (copier que les lignes pour la personne en cours de traitement dans ma boucle) dans la feuille de chaque feuille mois.

2-Puis une personne peut ne pas être planinfiée pour 1 ou pluisiers mois, je fais un test pour compter le nombre d'occurrence.

Puis je crée un classeur dans lequel (la première feuille) je viens de coller la copie faite au point 1

et après ce mois je boucle sur un autre mois, je copie si données et je colle en décalant d'une ligne ainsi de suite.

Le problème c'est que cela ne fonctionne pas comme je veux, j'ai dû recommencer et perdre tout mon code que j'ai pu reconstituer et mais cette fois je n'ai aucun résultat ni aucun bug.

Pouvez-vous svp m'aider à voir plus clair ?

Ci-après le code.

Je mets aussi le fichier de départ

Et le rendu

Merci pour votre aide

Sub Creation_ClasseurCumulMois_Planning_ParPersonne()

Application.ScreenUpdating = False
Application.EnableEvents = False

Dim Fichier As String
Dim Filtre As String
Dim i As Long
Dim j As Long
'Dim Feuille As String
Dim Feuille As Worksheet
Dim Ws As Worksheet

'Boucle et compteur sur les collaborateurs existants
For i = ThisWorkbook.Worksheets("F.Collaborateurs").Range("E" & Rows.Count).End(xlUp).Row To 6 Step -1
'le nom du classeur ' nom du collaborateur
Fichier = ThisWorkbook.Worksheets("F.Collaborateurs").Range("E" & i).Value
'la valeur du filtre 'nom du collaborateur
Filtre = ThisWorkbook.Worksheets("F.Collaborateurs").Range("E" & i).Value

       'Ajout d un nouveau classeur
        Set wbk = Workbooks.Add
        'wbk.Activate
        'Première étape Pour détecter les différentes lignes à partir desquelles on colle les planning
        wbk.Sheets(1).Range("D5").Value = "PLANNING " & Fichier

   'Je parcours les feuilles du classeur, je cherche à isoler les feuilles m'intéressent (MOIS)
    For j = ThisWorkbook.Worksheets.Count To 1 Step -1
    'Je voudrais m'arrêter que quand la couleur de l'onglet de la Feuil est de 37( donc les mois) et que c'est rempli _
   '(test sur les 10 premieres lignes
   'If ThisWorkbook.Worksheets(j).Tab.ColorIndex = 37 And _
   'Application.WorksheetFunction.CountA(ThisWorkbook.Worksheets(j).Range("D9:AL10")) > 0 Then
        For Each Feuille In Worksheets
            If Feuille.Tab.ColorIndex = 37 And _
           Application.WorksheetFunction.CountA(ThisWorkbook.Worksheets(j).Range("D9:AL10")) > 0 Then  'Voir si le planning de ce mois est rempli

       'Affectation à la variable WS la feuille du mois
          Set Ws = Feuille

            'For NbMois = 1 To Fonction_Nbre_Onglet_Bleu

               'vérifie si le collaborateur est plannifé dans le mois
               '**************
               '***************

               'Je regarde si dans la feuille (planning du mois)
                If Application.WorksheetFunction.CountIf(Ws.Range("E:E"), Fichier) > 0 Then
                  Ws.Activate
                  ActiveSheet.Range("$D$8:$AL$2000").AutoFilter Field:=2, Criteria1:=Filtre
                  Range("D7").Select
                  ActiveCell.CurrentRegion.Select
                  Selection.Copy

                  'J'active le nouveau classeur crée pour y coller les données du planning
                   wbk.Activate
                   ' Suite Pour détecter les différentes lignes à partir desquelles on colle les planning
                   DernLign1 = Range("D" & Rows.Count).End(xlUp).Row
                   Range("F" & DernLign1 + 1).Value = "Mois " & Ws.Name
                   Range("D" & DernLign1 + 2).Select
                   Selection.PasteSpecial

                   'Dans mon petit encadré qui me sert de trame pour passer les arguments de mes fonctions,
                   'Je postionne mes arguments
                   'ThisWorkbook.Sheets("Sauvegarde_Export").Range("H46").Value = Feuille
                   ThisWorkbook.Sheets("Sauvegarde_Export").Range("H45").Value = Fichier

               Columns("F:AL").Select
               Selection.ColumnWidth = 5

               Columns("A:C").Select
              Selection.ColumnWidth = 0.5

               Range("F2:PV4").Select
              With Selection.Font
                  .Name = "Verdana"
                  .Size = 7
              End With

            'Next NbMois
                 wbk.SaveAs Filename:=ThisWorkbook.Worksheets("Sauvegarde_Export").Range("B22").Value & _
                "\" & "Planning Global " & "" & Fichier

                '  ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Worksheets("Sauvegarde_Export").Range("B22").Value & _
                "\" & "Planning Global " & "" & Fichier & ".xlsx"

                 wbk.Close

                             End If
                    End If
                Next Feuille
          Next j
Next i

'Sheets("Sauvegarde_Export").Range("D18").Select

Set wbk = Nothing
Set Ws = Nothing

Application.ScreenUpdating = True
Application.EnableEvents = True

Sheets("Sauvegarde_Export").Activate

End Sub

Cela doit être la fatigue, je fermais ma boucle très tôt.

Ci-après la solution:

Sub Creation_ClasseurCumulMois_Planning_ParPersonne()

Application.ScreenUpdating = False
Application.EnableEvents = False

Dim Fichier As String
Dim Filtre As String
Dim i As Long
Dim j As Long
'Dim Feuille As String
Dim Feuille As Worksheet
Dim Ws As Worksheet

'Boucle et compteur sur les collaborateurs existants
For i = ThisWorkbook.Worksheets("F.Collaborateurs").Range("E" & Rows.Count).End(xlUp).Row To 6 Step -1
'le nom du classeur ' nom du collaborateur
Fichier = ThisWorkbook.Worksheets("F.Collaborateurs").Range("E" & i).Value
'la valeur du filtre 'nom du collaborateur
Filtre = ThisWorkbook.Worksheets("F.Collaborateurs").Range("E" & i).Value

       'Ajout d un nouveau classeur
        Set wbk = Workbooks.Add
        wbk.Activate
        'Première étape Pour détecter les différentes lignes à partir desquelles on colle les planning
        wbk.Sheets(1).Range("D5").Value = "PLANNING " & Fichier

   'Je parcours les feuilles du classeur, je cherche à isoler les feuilles m'intéressent (MOIS)
    For j = ThisWorkbook.Worksheets.Count To 1 Step -1
    'Je voudrais m'arrêter que quand la couleur de l'onglet de la Feuil est de 37( donc les mois) et que c'est rempli _
   '(test sur les 10 premieres lignes
   'If ThisWorkbook.Worksheets(j).Tab.ColorIndex = 37 And _
   'Application.WorksheetFunction.CountA(ThisWorkbook.Worksheets(j).Range("D9:AL10")) > 0 Then
        'For Each Feuille In Worksheets
            If ThisWorkbook.Worksheets(j).Tab.ColorIndex = 37 And _
           Application.WorksheetFunction.CountA(ThisWorkbook.Worksheets(j).Range("D9:AL10")) > 0 Then  'Voir si le planning de ce mois est rempli

       'Affectation à la variable WS la feuille du mois
          Set Ws = ThisWorkbook.Worksheets(j)

            'For NbMois = 1 To Fonction_Nbre_Onglet_Bleu

               'vérifie si le collaborateur est plannifé dans le mois
               '**************
               '***************

               'Je regarde si dans la feuille (planning du mois)
                If Application.WorksheetFunction.CountIf(Ws.Range("E:E"), Fichier) > 0 Then
                  Ws.Activate
                  ActiveSheet.Range("$D$8:$AL$2000").AutoFilter Field:=2, Criteria1:=Filtre
                  Range("D7").Select
                  ActiveCell.CurrentRegion.Select
                  Selection.Copy

                  'J'active le nouveau classeur crée pour y coller les données du planning
                   wbk.Activate
                   ' Suite Pour détecter les différentes lignes à partir desquelles on colle les planning
                   DernLign1 = Range("D" & Rows.Count).End(xlUp).Row
                   Range("F" & DernLign1 + 1).Value = "Mois " & Ws.Name
                   Range("D" & DernLign1 + 2).Select
                   Selection.PasteSpecial

                   'Dans mon petit encadré qui me sert de trame pour passer les arguments de mes fonctions,
                   'Je postionne mes arguments
                   'ThisWorkbook.Sheets("Sauvegarde_Export").Range("H46").Value = Feuille
                   ThisWorkbook.Sheets("Sauvegarde_Export").Range("H45").Value = Fichier

               Columns("F:AL").Select
               Selection.ColumnWidth = 5

               Columns("A:C").Select
              Selection.ColumnWidth = 0.5

               Range("F2:PV4").Select
              With Selection.Font
                  .Name = "Verdana"
                  .Size = 7
              End With

            'Next NbMois

                             End If
                    End If

                'Next Feuille

          Next j

              wbk.SaveAs Filename:=ThisWorkbook.Worksheets("Sauvegarde_Export").Range("B22").Value & _
                "\" & "Planning Global " & "" & Fichier

                '  ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Worksheets("Sauvegarde_Export").Range("B22").Value & _
                "\" & "Planning Global " & "" & Fichier & ".xlsx"

                 wbk.Close

Next i

'Sheets("Sauvegarde_Export").Range("D18").Select

Set wbk = Nothing
Set Ws = Nothing

Application.ScreenUpdating = True
Application.EnableEvents = True

'Sheets("Sauvegarde_Export").Activate

End Sub

Bonjour,

Je dispose d'un classeur avec plusieurs feuilles dont des feuilles portant le nom des mois de l'année. Dans ces mois de l'année, j'ai un planning par personnes, je souhaiterais mettre dans un seul fichier excel tout le planning par mois d'une personne.

1-Parmi les feuilles, il y a la liste des personnes. Cela me permet de faire ma boucle et mon filtre (copier que les lignes pour la personne en cours de traitement dans ma boucle) dans la feuille de chaque feuille mois.

2-Puis une personne peut ne pas être planinfiée pour 1 ou pluisiers mois, je fais un test pour compter le nombre d'occurrence.

Puis je crée un classeur dans lequel (la première feuille) je viens de coller la copie faite au point 1

et après ce mois je boucle sur un autre mois, je copie si données et je colle en décalant d'une ligne ainsi de suite.

Le problème c'est que cela ne fonctionne pas comme je veux, j'ai dû recommencer et perdre tout mon code que j'ai pu reconstituer et mais cette fois je n'ai aucun résultat ni aucun bug.

Pouvez-vous svp m'aider à voir plus clair ?

Ci-après le code.

Je mets aussi le fichier de départ

Classeur Global.xlsm

Et le rendu

Exemple du rendu souhaité.xlsx

Merci pour votre aide

Sub Creation_ClasseurCumulMois_Planning_ParPersonne()

Application.ScreenUpdating = False
Application.EnableEvents = False

Dim Fichier As String
Dim Filtre As String
Dim i As Long
Dim j As Long
'Dim Feuille As String
Dim Feuille As Worksheet
Dim Ws As Worksheet

'Boucle et compteur sur les collaborateurs existants
For i = ThisWorkbook.Worksheets("F.Collaborateurs").Range("E" & Rows.Count).End(xlUp).Row To 6 Step -1
'le nom du classeur ' nom du collaborateur
Fichier = ThisWorkbook.Worksheets("F.Collaborateurs").Range("E" & i).Value
'la valeur du filtre 'nom du collaborateur
Filtre = ThisWorkbook.Worksheets("F.Collaborateurs").Range("E" & i).Value

       'Ajout d un nouveau classeur
        Set wbk = Workbooks.Add
        'wbk.Activate
        'Première étape Pour détecter les différentes lignes à partir desquelles on colle les planning
        wbk.Sheets(1).Range("D5").Value = "PLANNING " & Fichier

   'Je parcours les feuilles du classeur, je cherche à isoler les feuilles m'intéressent (MOIS)
    For j = ThisWorkbook.Worksheets.Count To 1 Step -1
    'Je voudrais m'arrêter que quand la couleur de l'onglet de la Feuil est de 37( donc les mois) et que c'est rempli _
   '(test sur les 10 premieres lignes
   'If ThisWorkbook.Worksheets(j).Tab.ColorIndex = 37 And _
   'Application.WorksheetFunction.CountA(ThisWorkbook.Worksheets(j).Range("D9:AL10")) > 0 Then
        For Each Feuille In Worksheets
            If Feuille.Tab.ColorIndex = 37 And _
           Application.WorksheetFunction.CountA(ThisWorkbook.Worksheets(j).Range("D9:AL10")) > 0 Then  'Voir si le planning de ce mois est rempli

       'Affectation à la variable WS la feuille du mois
          Set Ws = Feuille

            'For NbMois = 1 To Fonction_Nbre_Onglet_Bleu

               'vérifie si le collaborateur est plannifé dans le mois
               '**************
               '***************

               'Je regarde si dans la feuille (planning du mois)
                If Application.WorksheetFunction.CountIf(Ws.Range("E:E"), Fichier) > 0 Then
                  Ws.Activate
                  ActiveSheet.Range("$D$8:$AL$2000").AutoFilter Field:=2, Criteria1:=Filtre
                  Range("D7").Select
                  ActiveCell.CurrentRegion.Select
                  Selection.Copy

                  'J'active le nouveau classeur crée pour y coller les données du planning
                   wbk.Activate
                   ' Suite Pour détecter les différentes lignes à partir desquelles on colle les planning
                   DernLign1 = Range("D" & Rows.Count).End(xlUp).Row
                   Range("F" & DernLign1 + 1).Value = "Mois " & Ws.Name
                   Range("D" & DernLign1 + 2).Select
                   Selection.PasteSpecial

                   'Dans mon petit encadré qui me sert de trame pour passer les arguments de mes fonctions,
                   'Je postionne mes arguments
                   'ThisWorkbook.Sheets("Sauvegarde_Export").Range("H46").Value = Feuille
                   ThisWorkbook.Sheets("Sauvegarde_Export").Range("H45").Value = Fichier

               Columns("F:AL").Select
               Selection.ColumnWidth = 5

               Columns("A:C").Select
              Selection.ColumnWidth = 0.5

               Range("F2:PV4").Select
              With Selection.Font
                  .Name = "Verdana"
                  .Size = 7
              End With

            'Next NbMois
                 wbk.SaveAs Filename:=ThisWorkbook.Worksheets("Sauvegarde_Export").Range("B22").Value & _
                "\" & "Planning Global " & "" & Fichier

                '  ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Worksheets("Sauvegarde_Export").Range("B22").Value & _
                "\" & "Planning Global " & "" & Fichier & ".xlsx"

                 wbk.Close

                             End If
                    End If
                Next Feuille
          Next j
Next i

'Sheets("Sauvegarde_Export").Range("D18").Select

Set wbk = Nothing
Set Ws = Nothing

Application.ScreenUpdating = True
Application.EnableEvents = True

Sheets("Sauvegarde_Export").Activate

End Sub
Rechercher des sujets similaires à "creation automatique classeurs sources feuilles existants"