Sub Macro1()
Dim ch As String 'déclare la variable ch (CHemin d'accès)
Dim lt As Variant 'déclare la varialbe lt (Ligne éTiquettes)
Dim dl As Long 'déclare la variable dl (Dernière Ligne)
Dim cel As Range 'déclare la variable cel (CELlule)
Dim pl As Range 'déclare la variable pl (PLage)
Dim ple As Range 'déclare la variable pla (PLage Entière)
Dim d1 As Object 'déclare la variable d1 (Dictionaire 1)
Dim d2 As Object 'déclare la variable d2 (Dictionaire 2)
Dim tp6 As Variant 'déclare la variable tp6 (TemPoraire champ 6)
Dim tp5 As Variant 'déclare la variable tp5 (TemPoraire champ 5)
Dim i As Long 'déclare la variable i (Incrément)
Dim j As Long 'déclare la variable j (incrément)
Dim tb() As Variant 'déclare le tableau de variables indéxées tb (TaBleau)
ch = ThisWorkbook.Path 'définit le chemin d'accès ch
With Sheets("Feuil1") 'prend en compte l'onglet "Feuil1"
lt = .Range("A1:K1") 'définit la ligne d'étiquettes lt
dl = .Cells(Application.Rows.Count, 6).End(xlUp).Row 'définit la dernière ligne éditée dl de la colonne 6 (=F)
If dl = 1 Then Exit Sub 'si aucune données de champ 6, sort de la procédure
Set pl = .Range("F2:F" & dl) 'définit la plage pl
Set ple = .Range("A2:K" & dl) 'définit la plage entière ple
Set d1 = CreateObject("Scripting.Dictionary") 'définit le dictionnaire d1
For Each cel In pl 'boucle sur toutes les cellules cel de la plage pl
d1(cel.Value) = "" 'alimente le dictionnaire d1
Next cel 'prochaine cellule de la boucle
tp6 = d1.keys 'récupère les valeurs uniques (sans doublon) du champ 6 dans le tableau temporaire tp6
For i = 0 To UBound(tp6) 'boucles 1 : sur toutes les valeurs du tableau tp6
Set d2 = CreateObject("Scripting.Dictionary") 'définit le dictionnaire d2
.Range("A1").AutoFilter Field:=6, Criteria1:=tp6(i) 'filtre le champ 6 en fonction du critère tp6(i)
For Each cel In pl.Offset(0, -1).SpecialCells(xlCellTypeVisible) 'boucle 2 : sur toutes les cellules visibles de la colonne E
d2(cel.Value) = "" 'alimente le dictionnaire d2
Next cel 'prochaine cellule de la boucle 2
tp5 = d2.keys 'récupère les valeurs uniques (sans doublon) du champ 5 filtré dans le tableau temporaire tp5
ReDim tb(UBound(tp5)) 'redimensionne le tableau de variables indexée tb
For j = 0 To UBound(tp5) 'boucle 3 : sur toutes les valeurs du tableau tp5
.Range("A1").AutoFilter Field:=5, Criteria1:=tp5(j) 'filtre le champ 5 en fonction du critère tp5(j)
tb(j) = ple.SpecialCells(xlCellTypeVisible) 'définit la variable indéxée tb(j)
.Range("A1").AutoFilter Field:=5 'supprime le filtre sur le champ 5
Next j 'prochaine valeur de la boucle 3
.Range("A1").AutoFilter 'annule le filtre automatique
Application.SheetsInNewWorkbook = UBound(tp5) + 1 'définit le nombre d'onglets pour les nouveau classeurs
Workbooks.Add 'ajoute un classeur
For j = 0 To UBound(tp5) 'boucle 3 : sur toutes les valeurs du tableau tp5
Sheets(j + 1).Name = tp5(j) 'renomme l'onglet du nouveau classeur par rapport au valeurs uniques du tableau tp5
Sheets(j + 1).Range("A1").Resize(1, 11) = lt 'ajoute la ligne d'étiquettes
Sheets(j + 1).Range("A2").Resize(UBound(tb(j), 1), 11) = tb(j) 'ajoute les données correspondantes
Next j 'prochaine valeur de la boucle 3
ActiveWorkbook.SaveAs Filename:=ch & "\" & tp6(i) & ".xls" 'renomme le classeur par rapport au tableau tp6
ActiveWorkbook.Close SaveChanges = True 'ferme le classeur créé (à commenter si tu veux le garder ouvert)
Erase tp5: Erase tb 'vide les tableaux tp5 et tb
Next i 'prochaine valeur de la boucle 1
End With 'fin de la prise en compte de l'onglet "Feuil1"
Application.SheetsInNewWorkbook = 3 'rétablit à 3 le nombre d'onglets par défaut dans les nouveaux classeurs
End Sub
