Bonjour rbmicho59, Isabelle
Je l'ai traité ne éclatant le résultat par fichiers ...
J'ai pris le critère en colonne 13
Option Explicit
Sub fractionner()
Dim Tbl As Variant, data As Variant, i%
Dim dico1 As Object, cle1 As Variant, result1 As Variant, prov1 As Variant
Dim xl As Excel.Application, wb As Excel.Workbook
Dim critere%
critere = 13
data = ActiveSheet.Cells(1, 1).CurrentRegion
Set dico1 = CreateObject("Scripting.Dictionary")
For i = LBound(data) + 1 To UBound(data) ' hors en-tête
dico1(data(i, critere)) = ""
Next
Set xl = CreateObject("Excel.Application")
xl.SheetsInNewWorkbook = 1
prov1 = data(1, critere)
For Each cle1 In dico1.Keys
Set wb = xl.Workbooks.Add
data(1, critere) = cle1 ' pour emmener aussi l'en-tête
result1 = filtreArray(data, critere, cle1)
wb.Sheets(1).Cells(1, 1).Resize(UBound(result1, 1), UBound(result1, 2)) = result1
wb.Sheets(1).Cells(1, critere).Value = prov1
wb.SaveAs (ThisWorkbook.Path & "\" & cle1 & ".xlsx")
wb.Close
Set wb = Nothing
Next
xl.Quit
Set xl = Nothing
MsgBox "Terminé !"
End Sub
reste à faire la re-compilation des fichiers.