Option Explicit
Public critere%
Sub dispatcher()
Dim Tbl As Variant, data As Variant, i As Long
Dim dico1 As Object, cle1 As Variant, result1 As Variant
Dim wb As Excel.Workbook
Dim MonRepertoire, Repertoire As FileDialog, racine As String
Dim colonne$
critere = 1 ' colonne A
racine = Split(ThisWorkbook.Name, ".")(0)
Set Repertoire = Application.FileDialog(msoFileDialogFolderPicker)
Application.FileDialog(msoFileDialogFolderPicker).Title = "Choix du répertoire de stockage des fichiers générés"
Repertoire.Show
If Repertoire.SelectedItems.Count = 0 Then Exit Sub
MonRepertoire = Repertoire.SelectedItems(1)
Dim c As Range
Set c = Rows(1).Find("Colonne*")
If Not c Is Nothing Then
data = Range(Cells(1, 1), Cells(Range("A1").End(xlDown).Row, Rows(1).Find("Colonne*").Column))
Else
data = Cells(1, 1).CurrentRegion
End If
Set dico1 = CreateObject("Scripting.Dictionary")
For i = LBound(data) + 1 To UBound(data) ' hors en-tête
dico1(data(i, critere)) = ""
Next
Application.ScreenUpdating = False
For Each cle1 In dico1.Keys
result1 = filtreArray(data, critere, cle1)
Set wb = Workbooks.Open(ThisWorkbook.Path & "\" & "Model.xlsx")
wb.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Resize(UBound(result1, 1), UBound(result1, 2)) = result1
If Not cle1 Like "750*" Then
wb.SaveAs (MonRepertoire & "\" & racine & "_" & cle1 & ".xlsx")
Else
wb.SaveAs (MonRepertoire & "\" & racine & "_" & Cells(2, 7) & ".xlsx")
End If
wb.Close
Set wb = Nothing
Next
Application.ScreenUpdating = True
MsgBox "Terminé, fichiers sauvegardés sous """ & MonRepertoire & "\" & """ !"
End Sub
avec un jeu d'essai allégé