Discussion :

[meumeu73.1]

Bonjour à tous,

J'ai une macro qui me permet de découper un fichier en plusieurs fichiers suivant certains critères. Le split fonctionnait correctement j'avais moins de 32000 lignes dans mon fichier, aujourd'hui, je suis proche de 40000 lignes.

J'ai donc eu un dépassement de capacité, j'ai passé quelques variable en long. Le processus a donc passé ces étapes jusqu'au message "type d'argument byref incompatible". et là, je sèche complètement, je ne suis pas à l'origine de cette macro, je m'y perd un peu.

Voici le code global.

L'exécution de la macro commence par SplitToutesFeuilles

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
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
Dim tab_infos(50) As Variant
Sub InitExport()
Dim i As Long
 
For i = 0 To UBound(tab_infos)
    tab_infos(i) = ""
Next i
End Sub
Function DejaInfos(name As String) As Boolean
Dim i As Long
 
trouve = False
i = 0
While Not trouve And i <= UBound(tab_infos)
    If tab_infos(i) = name Then
        trouve = True
    Else
        i = i + 1
    End If
Wend
DejaInfos = trouve
End Function
Sub InsertTabInfos(name As String)
Dim i As Long
 
trouve = False
i = 0
While Not trouve And i <= UBound(tab_infos)
    If tab_infos(i) = "" Then
        tab_infos(i) = name
        trouve = True
    Else
        If tab_infos(i) = name Then
            trouve = True
        Else
            i = i + 1
        End If
    End If
Wend
 
End Sub
Sub TraitementSplit(source As String, champ As String, champ2 As String, critere As String, rgp As Boolean)
' Traitement de l'onglet source qui est splité selon le champ, le champ2 servant de critere de regroupement si rgp est vrai
' La valeur de critere peut servir à ne sélectionner que les enregistrement répondant à sa valeur
Dim val_champ1 As String
Dim val_champ2 As String
Dim i As Long
Dim soc As Integer
Dim bu As Integer
Dim col As Integer
 
Application.ScreenUpdating = False
Application.Calculation = xlManual ' bloque le calcul automatique.
soc = LabelLigne(source, champ, 1)
If soc < 0 Then
    MsgBox ("ATTENTION le libellé du champ utilisé pour le split n'existe pas dans le fichier source : " & champ)
    Exit Sub
End If
If champ2 <> "" Then
    bu = LabelLigne(source, champ2, 1)
End If
If critere = "" Then
    col = -1
Else
    col = soc
End If
i = 2
nb_enreg = Application.Min(Range("NB_enregistrements"), LastFreeLine(source) - 1)
 
While Worksheets(source).Cells(i, 1) <> "" And i - 1 <= nb_enreg
    'Application.StatusBar = i & " / " & nb_enreg
    If IsError(Worksheets(source).Cells(i, soc)) Then
        GoTo Skip
    End If
    val_champ1 = Worksheets(source).Cells(i, soc)
    If rgp Then
        If champ2 <> "" And bu > 0 Then
            If IsError(Worksheets(source).Cells(i, bu)) Then
                GoTo Skip
            End If
            val_champ2 = Worksheets(source).Cells(i, bu)
        End If
        val_champ1 = Regroupement2(val_champ1, val_champ2)
    End If
    If TestCritere(val_champ1, col, critere) Then
        Call TestOnglet(val_champ1)
        If LastFreeLine(val_champ1) - 1 = 1 Then
            Call LigneEntete(source, val_champ1)
        End If
        Worksheets(source).Activate
        Rows(i & ":" & i).Select
        Selection.Copy
        Worksheets(val_champ1).Select
        lg = LastFreeLine(val_champ1)
        Worksheets(val_champ1).Activate
        Rows(lg & ":" & lg).Select
        ActiveSheet.Paste
    End If
Skip:
    i = i + 1
Wend
Application.Calculation = xlAutomatic ' remet en place le calcul automatique
End Sub
Sub InitFields()
Worksheets("Actions").Activate
Range("FichierATraiter").Select
Call FormatCell("Normal")
Range("OngletATraiter").Select
Call FormatCell("Normal")
Range("ListeVal").Select
Call FormatCell("Normal")
Range("CritereSelect").Select
Call FormatCell("Normal")
End Sub
Sub SplitToutesFeuilles()
Dim nomfichier As String
Dim feuille As String
Dim lst()
Dim i As Long
lst = Range("Liste_Onglets").Value
nomfichier = ""
Call DebutChrono(True)
Call InitExport
 
For i = 1 To UBound(lst)
    feuille = lst(i, 1)
    If Len(feuille) > 0 Then
        Application.StatusBar = "Import de " & feuille
        Application.DisplayAlerts = False
        nomfichier = SelectLoadFeuille(feuille, nomfichier)
        Application.DisplayAlerts = True
        Range("FichierATraiter").Value = nomfichier
        Range("OngletATraiter").Value = feuille
        FormatFeuille (feuille)
        Range("OngletAtraiter").Value = feuille
        Application.StatusBar = "Traitement de " & feuille
        Call SplitparSociete
        Application.StatusBar = "Export de " & feuille
        Call ExportFichiers
        Application.DisplayAlerts = False
        Worksheets(feuille).Delete
        Application.DisplayAlerts = True
    End If
Next i
Application.StatusBar = "FIN : " & ArretChrono(True) / 60
End Sub
Sub SplitToutesFeuilles2()
Dim nomfichier As String
Dim feuille As String
Dim lst()
Dim i As Long
lst = Range("Liste_Onglets").Value
nomfichier = ""
Call DebutChrono(True)
Call InitExport
 
For i = 1 To UBound(lst)
    feuille = lst(i, 1)
    If Len(feuille) > 0 Then
        Application.StatusBar = "Import de " & feuille
        Application.DisplayAlerts = False
        nomfichier = SelectLoadFeuille(feuille, nomfichier)
        Application.DisplayAlerts = True
        Range("FichierATraiter").Value = nomfichier
        Range("OngletATraiter").Value = feuille
        FormatFeuille (feuille)
        Range("OngletAtraiter").Value = feuille
        Application.StatusBar = "Traitement de " & feuille
        Call SplitparSociete
        Application.DisplayAlerts = False
        Worksheets(feuille).Delete
        Application.DisplayAlerts = True
    End If
Next i
 
Application.StatusBar = "Export"
Call ExportFichiers
 
Application.StatusBar = "FIN : " & ArretChrono(True) / 60
End Sub
Function CTRL_RGP(onglet As String, champ1 As String, champ2 As String, Optional champ3 As String) As Boolean
Dim i As Long
 
c1 = LabelLigne(onglet, champ1, 1)
If champ2 <> "" Then
    c2 = LabelLigne(onglet, champ2, 1)
Else
    c2 = 1
End If
If champ3 <> "" Then
    c3 = LabelLigne(onglet, champ3, 1)
Else
    c3 = 1
End If
 
If c1 > 0 And c2 > 0 And c3 > 0 Then
    CTRL_RGP = True
Else
    CTRL_RGP = False
End If
 
End Function
Sub SplitparSociete()
Dim onglet As String
Dim champ As String
Dim champ2 As String
Dim champ3 As String
Dim critere As String
Dim tri As String
Dim rgp As Boolean
Dim perf As Boolean
Dim ctrl As Boolean
 
Call Param_Off
 
Call DebutChrono
Call InitFields
Call RAZ_Rapport("Error")
Worksheets("Actions").Activate
onglet = Range("OngletAtraiter").Value
champ = Range("ListeVal").Value
critere = Range("CritereSelect").Value
perf = Range("Perf").Value
 
If Range("Regroupement").Value = "Oui 2 critères" Then
    rgp = True
    champ2 = Range("RGP").Cells(1, 2)
    ctrl = CTRL_RGP(onglet, champ, champ2)
Else
    If Range("Regroupement").Value = "Oui 3 critères" Then
        rgp = True
        champ2 = Range("RGP").Cells(1, 2)
        ctrl = CTRL_RGP(onglet, champ, champ2)
        champ3 = Range("RGP").Cells(1, 3)
        ctrl = ctrl And CTRL_RGP(onglet, champ, champ3)
    Else
        ctrl = True
        rgp = False
    End If
End If
 
If Not ctrl Then
    MsgBox "Les champs de regroupements n'existent pas dans l'onglet à traiter. Veuillez corriger le paramétrage"
Else
If Range("FichierAtraiter").Value = "" Then
    Range("FichierAtraiter").Select
    Call FormatCell("Insatisfaisant")
    MsgBox "Veuillez choisir un fichier à traiter"
Else
    If onglet = "" Or Range("FichierAtraiter").Value = "" Then
        Range("OngletAtraiter").Select
        Call FormatCell("Insatisfaisant")
        MsgBox "Veuillez choisir un fichier à traiter"
    Else
        If champ = "" Then
            Range("ListeVal").Select
            Call FormatCell("Insatisfaisant")
            MsgBox "Veuillez saisir le champ sur lequel le traitement basera le split"
        Else
            x = LabelLigne(onglet, Range("CritereTri").Value, 1)
            tri = ConvertToLetter(LabelLigne(onglet, Range("CritereTri").Value, 1))
            oldStatusBar = Application.DisplayStatusBar
            If perf Then
                Call TraitementSplitPerf(onglet, champ, champ2, critere, rgp, champ3)
            Else
                Call TraitementSplit(onglet, champ, champ2, critere, rgp)
            End If
            Call FormatToutesFeuilles(tri, onglet)
            Application.ScreenUpdating = True
            Worksheets("Actions").Activate
            'If SheetExists("Error") And LastFreeLine("Error") - 1 > 1 Then
                ' MsgBox "Fin de traitement avec ERREUR : " & ArretChrono & " secondes"
                'Application.StatusBar = "Fin de traitement avec ERREUR : " & ArretChrono & " secondes"
            'Else
                ' MsgBox "Fin de traitement : " & ArretChrono & " secondes"
                'Application.StatusBar = "Fin de traitement : " & ArretChrono & " secondes"
            'End If
            Range("EXEC_Time") = ArretChrono / 60
            ' Application.StatusBar = oldStatusBar
        End If
    End If
End If
End If
Call Param_On
 
End Sub
Sub FormatToutesFeuilles(tri As String, Optional onglet_src As String)
Dim i As Long
Application.ScreenUpdating = False
i = 1
While Worksheets(i).name <> "Actions"
    If Worksheets(i).name <> "Error" Then
        If onglet_src <> "" Then
            Call FormatFeuilleRef(Worksheets(i).name, onglet_src)
        Else
            Call FormatFeuille(Worksheets(i).name)
        End If
        If tri <> "" Then
            Call FormatTri(Worksheets(i).name, tri)
        End If
    End If
    i = i + 1
Wend
Application.ScreenUpdating = True
End Sub
Sub FormatTri(onglet As String, tri As String)
    Worksheets(onglet).Activate
    rg = tri & "1:" & tri & LastFreeLine(onglet) - 1
    Call SetFilter(onglet)
    Worksheets(onglet).AutoFilter.Sort.SortFields.Add2 Key:=Range(rg), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers
    With Worksheets(onglet).AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
 
End Sub
 
Sub LigneEntete(src As String, targ As String)
    Worksheets(src).Activate
    Rows(1 & ":" & 1).Select
    Selection.Copy
    Worksheets(targ).Select
    Worksheets(targ).Activate
    Rows(1 & ":" & 1).Select
    ActiveSheet.Paste
End Sub
Function Regroupement(critere As String) As String
Dim res As String
Dim i As Long
rgp = "Regroupements"
If critere = "" Then
    trouve = True
Else
    trouve = False
End If
i = 1
res = critere
While Worksheets(rgp).Cells(i, 1) <> "" And Not trouve
    If Worksheets(rgp).Cells(i, 1) = critere Then
        trouve = True
        res = Worksheets(rgp).Cells(i, 2)
    End If
    i = i + 1
Wend
Regroupement = res
End Function
Function Regroupement2(critere As String, critere2 As String) As String
Dim res As String
Dim As Long
rgp = "Regroupements"
If critere = "" Then
    trouve = True
Else
    trouve = False
End If
i = 2
res = critere
While Worksheets(rgp).Cells(i, 1) <> "" And Not trouve
    xx = Worksheets(rgp).Cells(i, 1)
    If Worksheets(rgp).Cells(i, 1) = critere Then
        If Worksheets(rgp).Cells(i, 2) = "*" Or Worksheets(rgp).Cells(i, 2) = critere2 Then
            trouve = True
            res = Worksheets(rgp).Cells(i, 3)
        End If
    End If
    i = i + 1
Wend
If Not trouve Then
    Call TestOnglet("Error")
    i = LastFreeLine("Error")
    Worksheets("Error").Cells(i, 1) = critere
    Worksheets("Error").Cells(i, 2) = critere2
    Worksheets("Error").Cells(i, 3) = "Criteres de regroupement introuvables"
End If
Regroupement2 = res
End Function
Sub ExportFichiers()
Dim rep As String
Dim fichier As String
Dim nomfic As String
Dim nom As String
Dim ficexp As String
Dim colfixe As String
Dim cartouche As String
Dim onglet As String
Dim feuilleAtraiter As String
Dim verrou1 As String
Dim verrou2 As String
Dim mdp As String
Dim bverrou As Boolean
Dim cf As String
Dim i As Long
 
Application.ScreenUpdating = False
racine = Range("DossierExport")
onglet = Range("OngletATraiter")
cf = Range("ColFixe")
' colfixe = ConvertToLetter(LabelLigne(onglet, Range("ColFixe"), 1) + 1)
cartouche = Range("CSP_CARTOUCHE").Cells(1, 1)
If cartouche <> "" Then
    Call TestOnglet("Infos")
    Sheets("Infos").Move after:=Sheets(Worksheets.Count)
    Worksheets("Actions").Activate
    Worksheets("Actions").Range("CSP_CARTOUCHE").Select
    Selection.Copy
    Worksheets("Infos").Activate
    Worksheets("Infos").Cells(1, 1).Select
    ' Coller valeur avec mise en forme
    Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone _
        , SkipBlanks:=False, Transpose:=False
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
End If
 
extension = ".xlsx"
 
If Range("ExportUnSeulFichier") = "Oui" Then
    onefic = True
    'Nom du fichier d'export
    ficexp = Range("FichierExport").Value
Else
    onefic = False
End If
verrou = Range("Verrouillage")
If verrou = "Oui" Then
    bverrou = True
    mdp = Range("MDP")
    verrou1 = ""
    verrou2 = ""
    If Range("ColDéverouillage") > 0 Then
        verrou1 = ConvertToLetter(Range("ColDéverouillage"))
        verrou2 = ConvertToLetter(Range("ColDéverouillage") + 5)
    End If
Else
    bverrou = False
End If
 
di = Range("DossierInter")
If di = "Oui" Then
    bdi = True
Else
    bdi = False
End If
 
 
i = 1
nb = 0
While Worksheets(i).name <> "Actions"
    If Worksheets(i).name <> "Error" Then
        If bdi Then
            dossier = DossierIntermediaire(Worksheets(i).name)
            rep = racine & "\" & dossier
        Else
            rep = racine & "\" & Worksheets(i).name
            ' rep = racine
        End If
        res = CreerDossier(rep)
        nom = Worksheets(i).name
        If onefic = False Then
                ficexp = onglet
        End If
        nomfic = Trigramme(Worksheets(i).name, ficexp)
        fichier = rep & "\" & nomfic & extension
 
        colfixe = ConvertToLetter(LabelLigne(nom, cf, 1) + 1)
 
        Application.DisplayAlerts = False
        'ajouter l'onglet
        If Not DejaInfos(nomfic) Then
            Call InsertTabInfos(nomfic)
            Call CopieFeuille(fichier, "Infos", "Infos", "", "", "", False, "")
        End If
        If onefic Then
            Call CopieFeuille(fichier, nom, onglet, colfixe, verrou1, verrou2, bverrou, mdp)
        Else
            Call CopieFeuille(fichier, nom, onglet, colfixe, verrou1, verrou2, bverrou, mdp)
        End If
 
        ' suppression de la feuille copiée
        Worksheets(nom).Delete
 
        Application.DisplayAlerts = True
        nb = nb + 1
    Else
        i = i + 1
    End If
Wend
Application.ScreenUpdating = True
 
'Application.StatusBar = "Nombre de fichiers créés = " & nb
End Sub
Function Trigramme(entite As String, onglet) As String
' La fonction Trigramme sert à générer le nom du fichier qui sera exporté en fonction de l'entité et de l'onglet
' le trigramme de l'entité est paramétré dans le champ nommé "CSP_TRIG"
trig = Range("CSP_TRIG")
 
' recherche du nom de l'entité
i = 1
trouve = False
While trig(i, 1) <> "" And Not trouve
    If trig(i, 1) = entite Then
        Trigramme = trig(i, 2) & "_" & onglet
        trouve = True
    End If
    i = i + 1
Wend
If Not trouve Then
    Trigramme = onglet
    ' MsgBox "Le trigramme de l'entité " & entite & " n'a pas été indentifié"
End If
End Function
Function DossierIntermediaire(nom As String) As String
' La fonction Trigramme sert à identifier le nom du dossier qui sera utilisé
' le nom est paramétré dans le champ nommé "CSP_DOSSIER"
Dim i As Long
 
dosin = Range("CSP_DOSSIER")
 
' recherche du nom
i = 2
trouve = False
While dosin(i, 1) <> "" And Not trouve
    If dosin(i, 1) = nom Then
        DossierIntermediaire = dosin(i, 2)
        trouve = True
    End If
    i = i + 1
Wend
If Not trouve Then
    DossierIntermediaire = ""
End If
End Function
 
Sub RAZ_Feuilles()
' Fonction pour supprimer toutes les feuilles créées par le traitement et qui se situent à gauche de la feuille "Actions"
Dim i As Long
Application.ScreenUpdating = False
i = 1
While Worksheets(1).name <> "Actions"
    Application.DisplayAlerts = False
    Worksheets(1).Delete
    Application.DisplayAlerts = True
    i = i + 1
Wend
Application.ScreenUpdating = True
Call InitExport
 
MsgBox "Nombre de feuilles supprimées = " & i - 1
End Sub
Function CreerDossier(Chemin As String) As Boolean
'par: Excel-Malin.com ( https://excel-malin.com )
    On Error GoTo CreerDossierErreur
 
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
 
If Len(Dir(Chemin, vbDirectory)) > 0 Then
CreerDossier = True
Exit Function
Else
        'suppression du dernier backslash si présent
        If Right(Chemin, 1) = Application.PathSeparator Then Chemin = Left(Chemin, Len(Chemin) - 1)
 
        'vérificacion si chemin local ou réseau
        If Left(Chemin, 2) = "\\" Then
            CheminReseau = True
        Else
            CheminReseau = False
        End If
 
        'décomposition du chemin
        If CheminReseau = False Then
            PartiesDeChemin = Split(Chemin, Application.PathSeparator)
            CheminPartielOK = ""
            PremierDossier = LBound(PartiesDeChemin)
        Else
            PartiesDeChemin = Split(Replace(Chemin, "\\", ""), Application.PathSeparator)
            CheminPartielOK = ""
            PremierDossier = LBound(PartiesDeChemin) + 1
        End If
 
    'tests et créations de (sous)dossiers
        For PartieDeChemin = PremierDossier To UBound(PartiesDeChemin)
 
            For CheminPartiel = LBound(PartiesDeChemin) To PartieDeChemin
 
                        If CheminReseau = False Then
                            CheminPartielOK = CheminPartielOK & PartiesDeChemin(CheminPartiel) & Application.PathSeparator
                        Else
                            CheminPartielOK = CheminPartielOK & PartiesDeChemin(CheminPartiel) & Application.PathSeparator
                        End If
 
                If CheminPartiel = PartieDeChemin Then
                        If CheminReseau = False Then
                                    If FSO.FolderExists(CheminPartielOK) = False Then
                                            MkDir CheminPartielOK
                                    End If
                        Else
                                    If Right(CheminPartielOK, 1) = Application.PathSeparator Then _
                                    CheminPartielOK = Left(CheminPartielOK, Len(CheminPartielOK) - 1)
 
                                    If Left(CheminPartielOK, 2) <> "\\" Then _
                                    CheminPartielOK = "\\" & CheminPartielOK
 
                                    If FSO.FolderExists(CheminPartielOK) = False Then
                                            MkDir CheminPartielOK
                                    End If
                        End If
                End If
            Next CheminPartiel
            CheminPartielOK = ""
        Next PartieDeChemin
End If
 
CreerDossier = True
Exit Function
CreerDossierErreur:
CreerDossier = False
End Function

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
193
194
Dim Data_RGP As Variant
Dim nb_RGP As Long
Dim DataRangeSRC As Variant
Dim DataRangeTRG As Variant
 
Sub TraitementSplitPerf(source As String, champ As String, champ2 As String, critere As String, rgp As Boolean, Optional champ3 As String)
' Traitement de l'onglet source qui est splité selon le champ, le champ2 servant de critere de regroupement si rgp est vrai
' La valeur de critere peut servir à ne sélectionner que les enregistrement répondant à sa valeur
Dim val_champ1 As String
Dim val_champ2 As String
Dim val_champ3 As String
Dim oldval As String
Dim i As Long
Dim c1 As Integer
Dim c2 As Integer
Dim c3 As Integer
Dim nb As Integer
Dim col As Integer
Dim debut As Long
Dim fin As Long
Dim dercol As Integer
Dim colonne As String
Dim nb_enreg As Long
 
Application.ScreenUpdating = False
Application.Calculation = xlManual ' bloque le calcul automatique.
c1 = LabelLigne(source, champ, 1)
If c1 < 0 Then
    MsgBox ("ATTENTION le libellé du champ utilisé pour le split n'existe pas dans le fichier source : " & champ)
    Exit Sub
End If
 
nb = 1
If champ2 <> "" Then
    c2 = LabelLigne(source, champ2, 1)
    rg2 = ConvertToLetter(c2)
    nb = 2
Else
    c2 = -1
End If
If champ3 <> "" Then
    c3 = LabelLigne(source, champ3, 1)
    rg3 = ConvertToLetter(c3)
    nb = 3
Else
    c3 = -1
End If
 
If critere = "" Then
    col = -1
Else
    col = c1
End If
 
If rgp Then
    Call Load_RGP(nb)
End If
 
i = 2
nb_enreg = Application.Min(Range("NB_enregistrements"), LastFreeLine(source) - 1)
' tri de la feuille selon le critère de split
rg1 = ConvertToLetter(c1)
Call SetFilter(source)
ActiveWorkbook.Worksheets(source).AutoFilter.Sort.SortFields.Add2 Key:=Range(rg1 & "1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers
If c2 > 0 Then
    ActiveWorkbook.Worksheets(source).AutoFilter.Sort.SortFields.Add2 Key:=Range(rg2 & "1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers
End If
If c3 > 0 Then
    ActiveWorkbook.Worksheets(source).AutoFilter.Sort.SortFields.Add2 Key:=Range(rg3 & "1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers
End If
 
With ActiveWorkbook.Worksheets(source).AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
 
dercol = Worksheets(source).Cells(1, Columns.Count).End(xlToLeft).Column
colonne = ConvertToLetter(dercol)
DataRangeSRC = Worksheets(source).Range("A2:" & colonne & nb_enreg + 1)
i = 1
While i <= nb_enreg
    If DataRangeSRC(i, 1) <> "" Then
        'DataRangeTRG = Worksheets(source).Range("A" & i & ":AG" & i)
        'Application.StatusBar = i & " / " & nb_enreg
        If IsError(DataRangeSRC(i, c1)) Then
            GoTo Skip
        End If
        val_champ1 = DetermineFeuille(i, c1, rgp, c2, c3)
        If TestCritere(val_champ1, col, critere) Then
            debut = i + 1
            Call TestOnglet(val_champ1)
            If LastFreeLine(val_champ1) - 1 = 1 Then
                Call LigneEntete(source, val_champ1)
            End If
            oldval = val_champ1
            While val_champ1 = oldval
                i = i + 1
                val_champ1 = DetermineFeuille(i, c1, rgp, c2, c3)
            Wend
            fin = i
 
            nbl = fin - debut
            ReDim DataRangeTRG(nbl, dercol)
            DataRangeTRG = Worksheets(source).Range("A" & debut & ":" & colonne & fin)
            lg = LastFreeLine(oldval)
            x = lg + nbl
            Worksheets(oldval).Range("A" & lg & ":" & colonne & x) = DataRangeTRG
            i = i - 1
        End If
    End If
Skip:
    i = i + 1
Wend
Application.Calculation = xlAutomatic ' remet en place le calcul automatique
End Sub
 
Function DetermineFeuille(lg As Integer, idx1 As Integer, rgp As Boolean, idx2 As Integer, idx3 As Integer) As String
Dim v1 As String
Dim v2 As String
Dim v3 As String
 
v1 = DataRangeSRC(lg, idx1)
If rgp Then
    If idx2 > 0 Then
        v2 = DataRangeSRC(lg, idx2)
    End If
    If idx3 > 0 Then
        v3 = DataRangeSRC(lg, idx3)
    End If
    v1 = Regroupement3(v1, v2, v3)
End If
DetermineFeuille = v1
End Function
Sub Load_RGP(nbchamp As Integer)
Dim rgp As String
Dim i As Long
 
rgp = "Regroupements"
i = LastFreeLine(rgp) - 1
x = ConvertToLetter(nbchamp + 1)
Data_RGP = Worksheets(rgp).Range("A2:" & x & i)
nb_RGP = i
End Sub
Function Regroupement3(critere As String, critere2 As String, critere3 As String) As String
Dim res As String
Dim i As Long
 
rgp = "Regroupements"
If critere = "" Then
    trouve = True
Else
    trouve = False
End If
If critere3 = "" Then
    crit3 = False
Else
    crit3 = True
End If
 
i = 1
res = critere
While Not trouve And i < nb_RGP
    If Data_RGP(i, 1) = critere Then
        If crit3 Then
            If (Data_RGP(i, 2) = "*" Or Data_RGP(i, 2) = critere2) And (Data_RGP(i, 3) = "*" Or Data_RGP(i, 3) = critere3) Then
                trouve = True
                res = Data_RGP(i, 4)
            End If
        Else
            If Data_RGP(i, 2) = "*" Or Data_RGP(i, 2) = critere2 Then
                trouve = True
                res = Data_RGP(i, 3)
            End If
        End If
    End If
    i = i + 1
Wend
If Not trouve Then
    Call TestOnglet("Error")
    i = LastFreeLine("Error")
    Worksheets("Error").Cells(i, 1) = critere
    Worksheets("Error").Cells(i, 2) = critere2
    If crit3 Then
        Worksheets("Error").Cells(i, 3) = critere3
        Worksheets("Error").Cells(i, 4) = "Criteres de regroupement introuvables"
    Else
        Worksheets("Error").Cells(i, 3) = "Criteres de regroupement introuvables"
    End If
End If
Regroupement3 = res
End Function

Désolé, ça fait beaucoup de codes. Si vous avez une idée de ce qui pourrait me donner ce message d'erreur, je suis preneur.

D'avance merci pour votre

Cdt,

Meumeu

[Invité]

Bonjour meumeu73.1

Il manque déjà une fonction ou une sub dans le code donné

Quand vous avez

Code :

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

c1 = LabelLigne(source, champ, 1)

Ou est LabelLigne ?

A+

[Alex020181]

Bonjour,

Aurais tu la possibilité de joindre un fichier ?

[meumeu73.1]

Bonjour meumeu73.1

Il manque déjà une fonction ou une sub dans le code donné

Quand vous avez

Code :

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

c1 = LabelLigne(source, champ, 1)

Ou est LabelLigne ?

A+

J'au du mal copié mon code pour le Sub.

J'ai déclaré LabelLigne en Long, j'ai un autre message d'erreur " Erreur de compilation - Tableau Attendu "

la ligne surligné en jaune

Code :

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

Sub TraitementSplitPerf(source As String, champ As String, champ2 As String, critere As String, rgp As Boolean, Optional champ3 As String)

[deedolith]

Quel est ton niveau en VBA ?

Si tu es débutant, ce n'est même pas la peine d'espérer comprendre ce code, et encore moins le mettre à jour.
Il est juste horrible !
je n'énumèrerai pas toutes les bêtises qu'il y a dedans, la liste serait trop longue.

Le plus prudent est peut être de repartir du code originel (et non celui que tu à modifié).

[Alex020181]

Aurais tu la possibilité de joindre un fichier ?

[meumeu73.1]

Bonjour,

Je suis un peu plus que débutant, mais pas vraiment expert, c'est pour cela que je demande de l'aide.

Voici le code original (SpliPerformanceV5 - Test.xlsm)

Je rappelle le premier message d'erreur que j'ai eu problème : dépassement de capacité, d'après ce que j'avais lu, il fallait passer certaines variables de Integer à Long. Mon fichier est passé de 30000 lignes à 39000 lignes.

J'ai joint un fichier test (SOURCE TEST.xlsm).

Fonctionnement du Split :
2 méthodes

Split d'une feuille pour 1 fichier splitté en plusieurs fichiers : c'est la partie à gauche avec les étapes 1, 2 et 3.

Split des plusieurs feuilles en plusieurs fichiers : c'est le bouton qui est positionné en F29 : rapports_multionglets (exports séparés)

c'est ce dernier qui m’intéresse.

En cliquant sur ce bouton, il va me demander quel fichier je veux splitter (SOURCE TEST.xslm), j'ai déjà indiquer les onglets que je voulais splitter en colonne G (FICHIER 1, FICHIER 2,....), le champ a utilisé est SPLIT (indiqué en E7)

Le split doit s'effectuer et les fichiers seront positionnés dans le répertoire suivant le chemin indiqué en F14, il doit créé un dossier par SPLIT1, SPLIT2, ... et mettre le fichier SPLIT avec les onglets FICHIER 1, FICHIER 2,....

J'espère que mes explications sont à peu près clair.

Merci.