Fractionner feuille Excel selon critère

Bonjour

j'ai déjà un code pour fractionner une feuille Excel en plusieurs fichiers

Sub crea_classeurs()
Dim i%
deb = 2
    Application.ScreenUpdating = False
    chemin = ActiveWorkbook.Path
    Set Ws = ActiveSheet
    Ws.Rows(1).Copy

    For i = 1 To 12

        Ws.Rows(1).Copy
        Workbooks.Add
        Set wk = ActiveWorkbook
        Selection.PasteSpecial Paste:=xlPasteAll
        Application.CutCopyMode = False
        fin = 900 + deb
        Ws.Rows(deb & ":" & fin).Copy
        wk.Sheets(1).Cells(2, 1).Select
        Selection.PasteSpecial Paste:=xlPasteAll
        fich = chemin & "\Class" & i & ".csv"
        ActiveWorkbook.SaveAs Filename:=fich, FileFormat:=xlOpenXMLWorkbookMacroEnabled
        ActiveWorkbook.Close
        deb = fin + 1
    Next

    Application.ScreenUpdating = True
End Sub

Cependant, cette fois je cherche à fractionner la feuille Excel sous condition (Unicité de la combinaison des valeurs des colonnes A et E)

J'ai pensé à rajouter une colonne qui représentera la concaténation des colonnes A et E, mais j'ai du mal à mettre en placer le code qui va diviser cette feuille en plusieurs fichiers, selon le critère ci-dessus

Pourriez-vous m'aider svp?

Merci d'avance

Bonjour,

Essayez ceci:

Sub Crea_Classeurs()
    Dim i As Long, Fin As Long, Deb As Long, DerLig As Long, Class As Long
    Dim Chemin As String, Fich As String
    Dim Ws As Worksheet

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Deb = 2
    DerLig = Range("A" & Rows.Count).End(xlUp).Row
    Chemin = ActiveWorkbook.Path
    Set Ws = Sheets(ActiveSheet.Name)
    Class = 1
    For i = 3 To DerLig + 1
        If Cells(i, "A") <> Cells(i - 1, "A") Or Cells(i, "E") <> Cells(i - 1, "E") Then
            Fin = i - 1
            Range(Ws.Cells(Deb, "A"), Ws.Cells(Fin, "E")).Copy
            Workbooks.Add
            Range("A2").PasteSpecial Paste:=xlPasteAll
            Range("A1:E1").Value = Array("Date", "I", "Q", "Lab", "Ac")
            Fich = Chemin & "\Class" & Class & ".csv"
            ActiveWorkbook.SaveAs Filename:=Fich, FileFormat:=xlOpenXMLWorkbookMacroEnabled
            ActiveWorkbook.Close
            Class = Class + 1
            Deb = Fin + 1
        End If
    Next
    Set Ws = Nothing
End Sub

Cdlt

Bonjour

un grand merci pour votre retour, cela fonctionne :)

J'ai mis le sujet en résolu

Bonne journée