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 |
type d'argument byref incompatible
Répondre avec citation
Partager