Discussion :

[kiki29]

Cet utilitaire permet de découper un fichier Excel en x fichiers dans un dossier créé automatiquement.
Ces fichiers seront composés d'un Nb de lignes/fichier avec ou sans l'entête.
Cet entête peut être composé de n lignes.
Ces fichiers auront dans leurs préfixes le n° d'ordre de leur génération précédé par l'indication du Nb de lignes par fichier.
Toutes ces valeurs et dénominations sont modifiables par l'utilisateur.

A associer avec cet autre utilitaire qui fait l'inverse : Fusion de fichiers Excel

Téléchargeable ici : Découpage d'un fichier Excel (2)

Extrait:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
Sub Découpage()
Dim iLastRow As Long, iLastCol As Long, i As Long, iRowDep As Long, iRowFin As Long, iNbFichiers As Long
Dim ClasseurTempo As Workbook, sDossier As String, sCheminFichier As String, sNom As String
Dim bVide As Boolean, bEntete As Boolean, FSO As Object, iNbLignes As Long, sPrefixe As String, sNomDossier As String
Dim Dep As Currency, Fin As Currency, Freq As Currency, iEntete As Long
 
    QueryPerformanceCounter Dep
 
    With Application
        .ScreenUpdating = False
        .StatusBar = ""
    End With
 
    bVide = ShParam.CheckBoxes("chkVider").Value = 1
    bEntete = ShParam.CheckBoxes("chkEntête").Value = 1
 
    sNomDossier = ShParam.Range("B1")
    sPrefixe = ShParam.Range("B2")
    iEntete = ShParam.Range("B3")
    iNbLignes = ShParam.Range("B4")
 
    iLastRow = ShFichier.Range("A" & Rows.Count).End(xlUp).Row
    iLastCol = ShFichier.Range(NumCol2Lettre(Columns.Count) & "1").End(xlToLeft).Column
    iNbFichiers = (iLastRow - 1) \ iNbLignes - (((iLastRow - 1) Mod iNbLignes) > 0)
 
    sDossier = ThisWorkbook.Path & "\" & sNomDossier
    If bVide Then
        Set FSO = CreateObject("Scripting.FileSystemObject")
        If FSO.FolderExists(sDossier) Then FSO.DeleteFolder sDossier, True
        Set FSO = Nothing
    End If
 
    CreationDossier sDossier
    sCheminFichier = sDossier & "\" & sPrefixe
    If iNbFichiers = 0 Then
        MsgBox "Il faut avoir sélectionné un fichier !", vbOKOnly + vbInformation
        Exit Sub
    End If
 
    iRowDep = iEntete + 1
    iRowFin = iRowDep + iNbLignes - 1
 
    Set ClasseurTempo = Workbooks.Add
 
    For i = 1 To iNbFichiers
        If bEntete Then
            ShFichier.Range("A1:A" & iEntete).Resize(, iLastCol).Copy ClasseurTempo.Worksheets(1).Range("A1")
            ShFichier.Range(ShFichier.Cells(iRowDep, "A"), ShFichier.Cells(iRowFin, iLastCol)).Copy ClasseurTempo.Worksheets(1).Range("A" & iEntete + 1)
        Else
            ShFichier.Range(ShFichier.Cells(iRowDep, "A"), ShFichier.Cells(iRowFin, iLastCol)).Copy ClasseurTempo.Worksheets(1).Range("A1")
        End If
 
        ClasseurTempo.Worksheets(1).Range("A1").Resize(, iLastCol).EntireColumn.AutoFit
 
        Application.DisplayAlerts = False
        sNom = sCheminFichier & "_" & iNbLignes & " (" & Format(i, "00000") & ").xls"
        If bEntete Then EnteteClasseurTempo iEntete, ClasseurTempo
        ClasseurTempo.SaveAs Filename:=sNom, FileFormat:=xlNormal
        Application.DisplayAlerts = True
 
        iRowDep = iRowDep + iNbLignes
        iRowFin = iRowFin + iNbLignes
        ClasseurTempo.Worksheets(1).Cells.Clear
        Application.StatusBar = i & " / " & iNbFichiers
    Next i
 
    ClasseurTempo.Close savechanges:=False
    Set ClasseurTempo = Nothing
    With ShParam
        .Select
        .Range("F1").Select
    End With
    Application.ScreenUpdating = True
 
    QueryPerformanceCounter Fin
    QueryPerformanceFrequency Freq
 
    Application.StatusBar = Application.StatusBar & " / Terminé : " & _
                            Format(((Fin - Dep) / Freq), "0.000 s") & " / " & _
                            Format(((Fin - Dep) / Freq) / iNbFichiers, "0.000 s")
End Sub