Sub Fragmenter()
Dim chemin$, a, d As Object, dd As Object, i&, x$, y$, z$, b, wb As Workbook, s, j&, w As Worksheet
chemin = ThisWorkbook.Path & "\Fragmentation\" 'dossier à adapter
If Dir(chemin, vbDirectory) = "" Then MkDir chemin 'création du dossier
With [A1].CurrentRegion.Resize(, 6)
a = .Value 'matrice, plus rapide
Set d = CreateObject("Scripting.Dictionary")
Set dd = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(a)
x = UCase(a(i, 1)): y = UCase(a(i, 6)): z = x & Chr(1) & y
If x <> "" And y <> "" Then
If Not dd.exists(z) Then
dd(z) = ""
d(x) = d(x) & Chr(1) & y
End If
End If
Next i
If d.Count = 0 Then Exit Sub
a = d.keys: b = d.items
Application.ScreenUpdating = False
Application.DisplayAlerts = False 'si les fichiers ont déjà été créés
For i = 0 To UBound(a)
Set wb = Workbooks.Add(xlWBATWorksheet) 'nouveau document
.AutoFilter 1, a(i) 'filtre automatique
.Copy wb.Sheets(1).Cells(1) 'copier-coller sur 1ère feuille
s = Split(b(i), Chr(1))
For j = 1 To UBound(s)
Set w = wb.Sheets.Add(After:=wb.Sheets(wb.Sheets.Count)) 'nouvelle feuille
w.Name = s(j)
With wb.Sheets(1).UsedRange
.AutoFilter 6, s(j) 'filtre automatique
.Resize(, 4).Copy w.Cells(1) 'copier-coller sur dernière feuille
End With
w.Columns.AutoFit 'ajustement largeurs
Next j
wb.Sheets(1).Delete
wb.Sheets(1).Activate
wb.SaveAs chemin & a(i), 51 'fichier .xlsx
wb.Close False
Next i
.Parent.AutoFilterMode = False 'retire le filtre
End With
End Sub