Découpage d'un fichier Excel

**kiki29** · 07/11/2017, 01h12

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 n'est composé que d'une seule ligne.
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.

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
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
Option Explicit
 
Private Declare Function QueryPerformanceCounter Lib "kernel32" (x As Currency) As Boolean
Private Declare Function QueryPerformanceFrequency Lib "kernel32" (x As Currency) As Boolean
 
Private Declare Function SHCreateDirectoryEx Lib "Shell32.dll" Alias "SHCreateDirectoryExA" _
                                             (ByVal hwnd As Long, _
                                              ByVal pszPath As String, _
                                              ByVal lngsec As Long) As Long
 
Private Function CreationDossier(sDossier) As Long
Dim Rep As Long
    Rep = SHCreateDirectoryEx(0&, sDossier, 0&)
End Function
 
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")
    iNbLignes = ShParam.Range("B3")
    iEntete = 1
 
    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 = 2
    iRowFin = iRowDep + iNbLignes - 1
 
    Set ClasseurTempo = Workbooks.Add
 
    For i = 1 To iNbFichiers
        If bEntete Then
            ShFichier.Range("A1").Resize(, iLastCol).Copy ClasseurTempo.Worksheets(1).Range("A1")
            ShFichier.Range(ShFichier.Cells(iRowDep, "A"), ShFichier.Cells(iRowFin, iLastCol)).Copy ClasseurTempo.Worksheets(1).Range("A2")
        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 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
 
Private Sub EnteteClasseurTempo(Wkb As Workbook)
    Wkb.Worksheets(1).Select
    ActiveWindow.FreezePanes = False
    Rows(2 & ":" & 2).Select
    ActiveWindow.FreezePanes = True
    Wkb.Worksheets(1).Range("A1").Select
End Sub
 
Private Function NumCol2Lettre(ByVal NumCol As Long) As String
Dim i As Long, x As Long, s As String
    For i = 6 To 0 Step -1
        x = (26 ^ (i + 1) - 1) / 25 - 1
        If NumCol > x Then
            s = s & Chr$(((NumCol - x - 1) \ 26 ^ i) Mod 26 + 65)
        End If
    Next i
    NumCol2Lettre = s
End Function
 
Private Sub PosBoutons()
Dim T As Range
    With ShParam
        .Activate
        .Rows(1).RowHeight = 14.25
 
        Set T = .Cells(1, 3)
 
        With .Shapes("chkVider")
            .Left = T.Left + 3
            .Top = T.Top + 2
            .Width = 135
            .Height = ShParam.Rows(1).RowHeight
        End With
 
        With .Shapes("chkEntête")
            .Left = ShParam.Shapes("chkVider").Left
            .Top = ShParam.Shapes("chkVider").Top + ShParam.Shapes("chkVider").Height + 2
            .Width = ShParam.Shapes("chkVider").Width
            .Height = ShParam.Shapes("chkVider").Height
        End With
 
        With .Buttons("btnSelect")
            .Left = ShParam.Shapes("chkVider").Left
            .Top = ShParam.Shapes("chkEntête").Top + ShParam.Shapes("chkEntête").Height + 10
            .Width = 100
            .Height = ShParam.Rows(1).RowHeight
        End With
 
        With .Buttons("btnDecoupage")
            .Left = ShParam.Buttons("btnSelect").Left + ShParam.Buttons("btnSelect").Width + 5
            .Top = ShParam.Buttons("btnSelect").Top
            .Width = 70
            .Height = ShParam.Rows(1).RowHeight
        End With
 
        .Range("F1").Select
    End With
End Sub
 
Sub SelectionFichier()
Dim Wkb As Workbook, iLastCol As Long
Dim FD As FileDialog
    Set FD = Application.FileDialog(msoFileDialogFilePicker)
    With FD
        .InitialFileName = ThisWorkbook.Path
        .AllowMultiSelect = False
        .Filters.Clear
        .Filters.Add "XLS", "*.xls*", 1
        .ButtonName = "Ouvrir fichier"
        .Title = "Sélectionner un fichier XLS"
    End With
 
    If FD.Show = True Then
        DoEvents
        Application.ScreenUpdating = False
        Set Wkb = Workbooks.Open(FD.SelectedItems(1), ReadOnly:=True)
        ShFichier.Cells.Delete Shift:=xlUp
        Wkb.Worksheets(1).UsedRange.Copy ShFichier.Range("A1")
        iLastCol = ShFichier.Range(NumCol2Lettre(Columns.Count) & Columns.Count).End(xlToLeft).Column
        ShFichier.Range("A1").Resize(, iLastCol).EntireColumn.AutoFit
        Wkb.Close SaveChanges:=False
        Set Wkb = Nothing
        With ShFichier
            .Select
            .Range("A1").Select
        End With
        With ShParam
            .Select
            .Range("F1").Select
        End With
        Application.ScreenUpdating = True
    End If
 
    Set FD = Nothing
End Sub

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

**curt** · 10/11/2017, 14h26

Salut Kiki29,

voilà une idée qu'elle est bonne.
Je vais utiliser ta méthode pour décharger un méga fichier ayant une ligne par heure/jour et ce depuis 10 ans.
Bref, je vais pouvoir archiver les années sans avoir à faires des couper/coller fastidieux.

Bien vu et ... bien joué.

Curt

**kiki29** · 12/11/2017, 01h32

Pour faire l'inverse voir ici : Fusion de fichiers Excel

**macgyver44** · 20/12/2021, 11h30

Bonjour kiki29,

Je suis justement à la recherche d'un utilitaire de cette forme.
Or, le fichier n'est plus disponible.
Serait-ce possible d'y accéder de nouveau ?
Merci d'avance.

**Pierre Fauconnier** · 23/12/2021, 14h26

Salut.

Il serait plus adéquat de poser votre question sur le forum en expliquant votre besoin.

Découpage d'un fichier Excel

Contribuez

Discussions similaires

Partager

Partager