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