Macro création fichier Excel à partir de critères dans une colonne

Bonjour,

Idée de base : À partir d'un fichier Excel contenant plusieurs colonnes, je souhaiterais qu'une macro crée automatiquement autant de fichiers qu'il y a de critères identiques dans une colonne donnée.

Maintenant :
Je souhaiterais créer autant de fichiers qu'il y a de "users". Jusqu'ici le code fonctionne. Cependant comment faire pour lancer cette macro depuis un autre fichier excel (exemple : Lancement.xlsx). Et qu'il effectue le travail en se basant sur le fichier de base (celui en copie joint).

Code:

---

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21

Sub CreeFichiers() Application.ScreenUpdating = False chemin = ThisWorkbook.Path & "\" With Sheets("Test") Set liste = CreateObject("scripting.dictionary") For Each u In .Range("G2:G" & .Range("G" & Rows.Count).End(xlUp).Row) liste(u.Value) = Format(u.Offset(0, -2), "yyyy_mm") Next u   For Each k In liste.keys .Range("$A$1").CurrentRegion.AutoFilter Field:=7, Criteria1:=k .Range("$A$1").CurrentRegion.SpecialCells(xlCellTypeVisible).Copy Workbooks.Add ActiveWorkbook.Sheets(1).Paste ActiveWorkbook.SaveAs chemin & "Saisies_" & k & "_" & liste(k) ActiveWorkbook.Close .ShowAllData Next k End With Application.ScreenUpdating = True End Sub

---

Code:

---

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25

Sub CreeFichiers() Application.ScreenUpdating = False cheminSource = Application.GetOpenFilename cheminSav = ActiveWorkbook.Path & "\fic_xls\"   With Workbooks.Open(cheminSource).Sheets("Test") Set liste = CreateObject("scripting.dictionary") For Each u In .Range("G2:G" & .Range("G" & Rows.Count).End(xlUp).Row) 'liste(u.Value) = Format(u.Offset(0, -2), "dd_mm_yyyy") liste(u.Value) = u.Offset(0, -4) Next u   For Each k In liste.keys .Range("$A$1").CurrentRegion.AutoFilter Field:=7, Criteria1:=k .Range("$A$1").CurrentRegion.SpecialCells(xlCellTypeVisible).Copy Workbooks.Add ActiveWorkbook.Sheets(1).Paste ActiveWorkbook.SaveAs cheminSav & k & "_" & liste(k) ActiveWorkbook.Close .ShowAllData Next k End With Application.ScreenUpdating = True ActiveWorkbook.Close False End Sub

---