A/S: Fractionner une feuille vers plusieurs fichiers

Bonjour le forum,

Je me demande s'il y a un module excel ou code VBA permettant de fractionner une feuille contenant 1 millions de lignes vers plusieurs fichiers, et ce selon les variables d'une colonne choisie.

Merci d'avance

Bonjour,

En partant d'une extraction des critères avec un dictionnaire sur la colonne (à moins qu'ils soient connus par avance) puis une copie de filtres successifs vers les différents classeurs :

Sub Test()

    Dim Cls As Workbook
    Dim Fe As Worksheet
    Dim Dico As Object
    Dim Cle As Variant
    Dim Plage As Range
    Dim Cel As Range
    Const NumCol As Integer = 6 'ici les critères sont en colonne F

    'gèle l'écran
    Application.ScreenUpdating = False

    'la feuille se nomme BDD, à adapter
    Set Fe = ThisWorkbook.Worksheets("BDD")

    'défini la plage sur toute la feuille
    Set Plage = DefPlage(Fe)

    Set Dico = CreateObject("Scripting.Dictionary")

    'dédoublonne les critères à l'aide du dictionnaire
    For Each Cel In Plage.Columns(NumCol).Cells: Dico(Cel.Value) = "": Next Cel

    'supprime la première cle qui est l'entête de colonne
    Dico.Remove Plage.Cells(1, NumCol).Value

    'boucle sur les critères
    For Each Cle In Dico.Keys

        Plage.AutoFilter NumCol, "=" & Cle

        'ajoute le classeur devant recevoir le résultat du filtrage
        Set Cls = Workbooks.Add

        'colle le résultat sur la feuille Feuille "Feuil1"
        Fe.AutoFilter.Range.EntireRow.Copy Cls.Worksheets("Feuil1").Range("A1")

        'supprime le filtre
        Plage.AutoFilter

        'enregistre le classeur dans le même dossier en lui donnant le nom du critère
        'mais attention à ce que les critères ne soient des dates (les caractères interdits comme /)
        Cls.SaveAs ThisWorkbook.Path & "\" & Cle & ".xlsx"

        'le ferme
        Cls.Close False

    Next Cle

    Application.ScreenUpdating = True

End Sub

Function DefPlage(Fe As Worksheet, Optional L As Long = 1, Optional C As Long = 1) As Range

    On Error GoTo Fin

    With Fe

        Set DefPlage = .Range(.Cells(L, C), _
                       .Cells(.Cells.Find("*", .[A1], -4123, , _
                       1, 2).Row, .Cells.Find("*", .[A1], -4123, , _
                       2, 2).Column))

    End With

    Exit Function

Fin:

    Set DefPlage = Nothing

End Function

Bonjour,

C'est exactement mon but, merci beaucoup

Crd,