Sub CréationFichiers()
Dim derlig&, d As Object, cel As Range, a, plage As Range
derlig = [D65536].End(xlUp).Row
If derlig = 1 Then Exit Sub
Application.ScreenUpdating = False
Application.DisplayAlerts = False 'si un fichier est déjà créé
'---liste des Services sans doublon---
Set d = CreateObject("Scripting.Dictionary")
For Each cel In [D2].Resize(derlig - 1)
If cel <> "" Then d(cel.Value) = cel.Value
Next
'---création des fichiers---
For Each a In d.keys
ActiveSheet.Copy
ActiveSheet.Name = a
Set plage = ActiveSheet.[D1].Resize(derlig)
plage.AutoFilter 1, "<>" & a
Set plage = plage.Offset(1).SpecialCells(xlCellTypeVisible)
ActiveSheet.AutoFilterMode = False
plage.EntireRow.Delete
ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & a
ActiveWorkbook.Close
Next
End Sub