Microsoft 365 ventiler un fichier excel dans de nouveaux classeurs excel

Sub extraction()
    Dim C As Range, Plage
    Application.ScreenUpdating = False
    With Feuil1
        Set Plage = .UsedRange
        If .FilterMode Then .ShowAllData
    End With
    Sheets.Add After:=Sheets(Sheets.Count)
    Feuil1.Columns("A:A").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("A1"), Unique:=True
    Rows(1).Delete
    For Each C In ActiveSheet.UsedRange
        Plage.AutoFilter Field:=1, Criteria1:=C
        Workbooks.Add
        Plage.SpecialCells(xlCellTypeVisible).Copy ActiveWorkbook.Sheets(1).[a1]
        Application.DisplayAlerts = False
        ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & C, FileFormat:=51
        ActiveWorkbook.Close False
    Next
    ActiveSheet.Delete
    Plage.AutoFilter
    Application.DisplayAlerts = True
    MsgBox "Création terminée." & vbLf & "Les fichiers se trouvent dans le même répertoire que ce classeur.", , "Information"    ' facultatif
End Sub