Bonjour,
Sub test()
Dim Dico As Object, Filtre As Worksheet
Set Dico = CreateObject("Scripting.Dictionary")
With ThisWorkbook.Sheets("Feuil1").Range("A1").CurrentRegion
For I = 2 To .Rows.Count
Dico(.Cells(I, "A").Value) = .Cells(I, "A").Value
Next
End With
Set Filtre = ThisWorkbook.Sheets.Add
For Each K In Dico.Keys
Filtre.Cells.Clear
Filtre.Range("A1") = "id"
Filtre.Range("A2") = K
With Workbooks.Add
With .Sheets.Add
FiltreActif ThisWorkbook.Sheets("Feuil1").Range("A1").CurrentRegion, Filtre.Range("A1").CurrentRegion, .Range("A1"), True
.Name = K
End With
Application.DisplayAlerts = False
.SaveAs K & Format(Date, "-yyyy-mm-dd")
Application.DisplayAlerts = True
.Close
End With
Next
Set Dico = Nothing
Application.DisplayAlerts = False
Filtre.Delete
Application.DisplayAlerts = True
Set Filtre = Nothing
End Sub
Function FiltreActif(RangeSource As Range, CriterRange As Range, CopyRange As Range, Optional Unique As Boolean = True) As Boolean
FiltreActif = False
On Error Resume Next
RangeSource.AdvancedFilter Action:= _
xlFilterCopy, CriteriaRange:=CriterRange _
, CopyToRange:=CopyRange, Unique:=Unique
DoEvents
If Err = 0 Then FiltreActif = True
'MsgBox Err.Description
On Error GoTo 0
End Function