Découper une feuille en plusieurs classeurs

[Rom1906]

Bonjour à tous,

J'ai un classeur excel qui contient une feuille. Celle-ci contient une ligne d'en-tête puis 125 000 lignes de données.

Afin de partager les données à analyser entre plusieurs collaborateurs, j'ai besoin de découper cette feuille en "paquets" de 10 000 et de créer un classeur par "paquet".

Je dois réaliser cette manipulation sur de nombreux fichiers de ce type et il ne contiennent pas toujours le même nombre d'enregistrements.

J'aimerai faire cette manipulation de manière automatique pour gagner du temps.

J'ai testé de nombreuses macros trouvées sur ce forum mais aucune ne correspond à ma demande.

Avez-vous une solution à me proposer ???

Merci d'avance pour votre aide.

 

[Robert]

Re : Découper une feuille en plusieurs classeurs

Bonjour Rom, bonjour le forum,

Essaie comme ça :

Sub Macro1()
Dim os As Object 'déclare la variable os (Ongelt Source)
Dim n As String 'déclare la variable n (Nom)
Dim ch As String 'déclare la variable ch (CHemin)
Dim dl As Long 'déclare la variable dl (Dernière Ligne)
Dim li As Long 'déclare la variable li (LIgne)
Dim i As Byte 'déclare la variable i (Incrément)
Dim cd As Workbook 'déclare la variable cd (Classeur Destination)
Dim od As Object 'déclare la variable od (Onglet Destination)
Dim dest As Range 'déclare la variable dest (cellule de DESTination)

Application.ScreenUpdating = False 'masque les rafraîchissements d'écran
Set os = ThisWorkbook.Sheets(1) 'définit l'onglet source os (ici le premier onglet du classeur, à adapter à ton cas)
n = Split(ThisWorkbook.Name, ".")(0) 'définit le nom n (nom du fichier sans l'extension)
ch = ThisWorkbook.Path & "\" 'définit le chemin d'accès
dl = os.UsedRange.Rows.Count 'définit la dernière ligne éditée dl du tableau source
i = 1 'initialise la variable i
For li = 2 To dl Step 10000 'boucle sur toutes les lignes du tableau par lot de 10000
    Application.Workbooks.Add 'ajoute un nouveau classeur
    Set cd = ActiveWorkbook 'définit le classeur destination cd
    cd.SaveAs (ch & n & "-P" & i & ".xlsx") 'enregistre-sous le nouveau classeur : nom-Pi.xlsx (à adapter en ".xls" si tu es sous excel 2003)
    Set od = cd.Sheets(1) 'définit l'onglet de destination (ici le premier, à adapter à ton cas)
    Set dest = od.Range("A1") 'définit la cellule de destination dest
    os.Rows(1).Copy dest 'copie la première ligne et la colle dans dest
    os.Range(os.Cells(li, 1), os.Cells(li + 9999, 1)).EntireRow.Copy dest.Offset(1, 0) 'copie 10000 lignes et les colle dans dest décalé d'une ligne vers le bas
    cd.Close SaveChanges:=True 'ferme, en enregistrant, le classeur de destination cd
    i = i + 1 'incrément i
Next li 'prochain lot de 10000 lignes de la boucle
Application.ScreenUpdating = True 'affiche les rafraîchissements d'écran
End Sub

Ce code est à placer dans tous les classeurs source que tu veux scinder en plusieurs classeurs de 10000 lignes chacun. Si les données ne se trouvent pas dans le premier onglet il te faudra l'adapter...

 

[Rom1906]

Re : Découper une feuille en plusieurs classeurs

Merci Robert, tout semble parfait !!!