Sub Test()
MonChemin = ThisWorkbook.Path
Application.ScreenUpdating = False
With ThisWorkbook.Sheets("données")
.Range("IS1:IV65536").Clear 'Nettoyage des zones de critères
.Cells.Sort Key1:=.Range("A2"), Key2:=.Range("B2"), Header:=xlYes, DataOption2:=xlSortTextAsNumbers 'Tri de la base pour supprime rles eventuelles lignes vides et trier les critères
.Range("A1").CurrentRegion.Resize(, 1).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Range("IS1"), Unique:=True 'Extraction du nb et des noms des classeurs à créer
.Range("A1").CurrentRegion.Resize(, 2).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Range("IU1"), Unique:=True 'Extraction des noms de Feuilles à créer dans les classeurs
For Each X In .Range(.Range("IS2"), .Range("IS2").End(xlDown)) 'Boucle sur les noms de classeurs
Application.DisplayAlerts = False 'Suppression des messages pour éviter les question en cas d'ecrasement d'un fichier deja existant
Set MonCLass = Workbooks.Add 'Creation du classeur
MonCLass.SaveAs Filename:=MonChemin & "\" & X 'On nomme le classeur
Application.DisplayAlerts = True 'Réactivation des messages
For i = 1 To Application.CountIf(.Columns(255), X) 'Boucle sur le nb de feuilles par classeur
Set MaFeuille = MonCLass.Sheets.Add(after:=MonCLass.Sheets(MonCLass.Sheets.Count)) 'On ajoute une feuille
MaFeuille.Name = .Range("IV2").Value 'On la nomme avec le critere IV2 (critere Code Entreprise)
.Range("A1").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=.Range("IU1:IV2"), CopyToRange:=MaFeuille.Range("A1") 'Filtre élaboré directement dans la feuille destination fraichement créée)
'Remarque : la zone decriteres est : .Range("IU1:IV2"). Elle ne change pas cf. ***
MaFeuille.Cells.EntireColumn.AutoFit 'Ajustement des colonnes
.Range("IU2:IV2").Delete '*** on supprime les lignes au fur et à mesure pour que les criteres evoluent
Next
Nettoyeur MonCLass 'On enleve Feuil1, Feuil2 etc ...
MonCLass.Close True 'On ferme le classeur
Next
.Range("IS1:IV65536").Clear 'Nettoyage des zones de critères
End With
Application.ScreenUpdating = True
End Sub
Sub Nettoyeur(Arg1)
Application.DisplayAlerts = False
For Each Y In Arg1.Sheets
If Left(Y.Name, 5) = "Feuil" Then Y.Delete
Next
Application.DisplayAlerts = True
End Sub