Fractionner feuille Excel en plusieurs fichier csv-dos

Bonsoir

je souhaite fractionner ma feuille Excel en plusieurs sous fichiers (format csv-dos)

ma feuille contient plus de 12 000 lignes

je souhaites avoir plusieurs fichiers de 900 lignes max

j'ai trouvé le code suivant sur le site, mais j'ai du mal à l'adapter à mon besoin

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

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

    Application.ScreenUpdating = True
End Sub

les titres de mes colonnes sont sur une seule ligne du coup j'ai modifié Ws.Rows(1).Copy pour le reste ca ne fonctionne pas (le traitement se bloque au bout de 2 fichiers, je pense que c'est dû au paramètre i allant de 1 à 2), et à chaque fois j'ai la ligne 2 vide (une ligne qui sépare le nom des colonnes des données) un grand merci d'avance pour votre aide

Bonjour,

Tu as raison pour le nombre de fichier qui est définit par le for i= 1 to 2.
Pour ta ligne 2 vide "l'entete" a recopier n'est pas une variable ici il fallait changer le 3 (wk.Sheets(1).Cells(3, 1).Select).

J'ai fait une version avec 2 variables a modifier et le reste devrait suivre.

Sub crea_classeurs()
Dim NbFichier, EnteteCopie, LigneMaxCSV, LigneMaxBase, NbCSV%

    Application.ScreenUpdating = False
    chemin = ActiveWorkbook.Path
    Set ws = ActiveSheet

EnteteCopie = 2 'nb ligne entete a copier
LigneCopie = 5 'nb ligne a copier (entete non comprise)

Suite = EnteteCopie + 1 'Ligne Début des données sans entete
LigneMaxBase = ws.Cells(Rows.Count, 1).End(xlUp).Row 'nb de ligne a "diviser" en plusieurs copie
NbCopie = Application.WorksheetFunction.RoundUp((LigneMaxBase - EnteteCopie) / LigneCopie, 0) 'nb de fichier copie

    For NbFichier = 1 To NbCopie
        'Copie l'entete sur le fichier csv
        ws.Rows("1:" & EnteteCopie).Copy
        Workbooks.Add
        Set wk = ActiveWorkbook
        Selection.PasteSpecial Paste:=xlPasteAll
        Application.CutCopyMode = False
        'Copie des lignes suivantes
        fin = LigneCopie + Suite - 1
        ws.Rows(Suite & ":" & fin).Copy
        wk.Sheets(1).Cells(EnteteCopie + 1, 1).Select
        Selection.PasteSpecial Paste:=xlPasteAll
        fich = chemin & "\Class" & NbFichier & ".xlsm"
        ActiveWorkbook.SaveAs Filename:=fich, FileFormat:=xlOpenXMLWorkbookMacroEnabled
        ActiveWorkbook.Close
        Suite = fin + 1
    Next NbFichier

    Application.ScreenUpdating = True
End Sub

Bon test

A+

un grand merci pour ton retour

Cela fonctionne parfaitement

J'aurai une dernière question, pourrais-tu stp me dire comment créer ces fichier en CSV-DOS, j'ai essayé de modifier l’extension dans le code mais ça ne fonctionne pas

Merci D'avance

Test comme ceci

            fich = chemin & "\Class" & NbFichier & ".csv"
        ActiveWorkbook.SaveAs Filename:=fich, FileFormat:=xlCSV, CreateBackup:=False

A+

merci pour ton retour, ça fonctionne :)

bonne soirée