erreur 1004 d'un filtre élaboré provenant d'un adaptation d'un code existant

**jpvba** · 04/03/2020, 00h07

Bonjour a vous tous cher(e)s ami(e)s du forum.

Grâce a l'aide de certains membre dont monsieur Philippe Tulliez (

)

J'ai améliorer un code tres lourd en code utilisant un filtre élaboré.

LE voici (il fonctionne nickel)

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
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
Sub creation()
 
    Dim x As Long
    Dim cell As Variant
 
    Dim y As Long
    Dim cellule As Variant
 
    Dim LettreProvLong As String
    Dim LettreFormat As String
    Dim LettreFamille As String
    Dim LettreClasse As String
    Dim LettreGroupe As String
    Dim LettreSousGroupe As String
    Dim LettreItem As String
    Dim LettreProvCourt As String
    Dim LettreRegLong As String
    Dim LettreRegCourt As String
    Dim LettreCouleur As String
    Dim LettreGAC As String
    Dim LettreFCGS As String
    Dim LettreNbProvLong As String
    Dim LettreNbProvCourt As String
    Dim LettreNbRegLong As String
    Dim LettreNbRegCourt As String
    Dim LettreNumero_de_ligne As String
 
    Dim tout_format As Range
    Dim tout_Famille As Range
    Dim tout_Classe As Range
    Dim tout_Groupe As Range
    Dim tout_SousGroupe As Range
    Dim tout_GAC As Range
 
    Dim element As Variant
 
    Dim PlageFiltre As Range
 
    Dim fe As Worksheet
 
    Dim cCreation As Workbook
    Set cCreation = ActiveWorkbook
 
    LettreProvLong = TrouveLettreColonne([prov_long_travail])
    LettreFormat = TrouveLettreColonne([no_format_travail])
    LettreFamille = TrouveLettreColonne([f_travail])
    LettreClasse = TrouveLettreColonne([c_travail])
    LettreGroupe = TrouveLettreColonne([g_travail])
    LettreSousGroupe = TrouveLettreColonne([sg_travail])
    LettreItem = TrouveLettreColonne([no_item_travail])
    LettreProvCourt = TrouveLettreColonne([prov_court_travail])
    LettreRegLong = TrouveLettreColonne([reg_long_travail])
    LettreRegCourt = TrouveLettreColonne([reg_court_travail])
    LettreCouleur = TrouveLettreColonne([no_couleur_travail])
    LettreGAC = TrouveLettreColonne([gac_travail])
    LettreFCGS = TrouveLettreColonne([fcgs_travail])
    LettreNbProvLong = TrouveLettreColonne([nb_prov_long])
    LettreNbProvCourt = TrouveLettreColonne([nb_prov_court])
    LettreNbRegLong = TrouveLettreColonne([nb_reg_long])
    LettreNbRegCourt = TrouveLettreColonne([nb_reg_court])
    LettreNumero_de_ligne = TrouveLettreColonne([numero_de_ligne])
 
    Set tout_format = Worksheets("Travail").Range(LettreFormat & 2, LettreFormat & LastLignUsedInColumn(LettreFormat))
    Set tout_Famille = Worksheets("Travail").Range(LettreFamille & 2, LettreFamille & LastLignUsedInColumn(LettreFamille))
    Set tout_Classe = Worksheets("Travail").Range(LettreClasse & 2, LettreClasse & LastLignUsedInColumn(LettreClasse))
    Set tout_Groupe = Worksheets("Travail").Range(LettreGroupe & 2, LettreGroupe & LastLignUsedInColumn(LettreGroupe))
    Set tout_SousGroupe = Worksheets("Travail").Range(LettreSousGroupe & 2, LettreSousGroupe & LastLignUsedInColumn(LettreSousGroupe))
    Set tout_GAC = Worksheets("Travail").Range(LettreGAC & 2, LettreGAC & LastLignUsedInColumn(LettreGAC))
 
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
 
'si il la dernière ligne utilisé de la description provinciale est 1, on quitte
 
    If LastLignUsedInColumn(LettreProvLong) = 1 Then
       MsgBox "Il y a seulement l'entete dans la colonne provinciale longue", vbCritical
       Exit Sub
    End If
'si la feuille filtre_item existe, on la supprime
 
    If sheetExists("filtre_item") Then Sheets("filtre_item").Delete
    If sheetExists("erreur de champs") Then Sheets("erreur de champs").Delete
    If sheetExists("critere erreur") Then Sheets("critere erreur").Delete
 
'nettoyer les lignes critiques afin d'enlever les caractères spéciaux
 
    For Each element In Union(tout_Classe, tout_Famille, tout_format, tout_Groupe, tout_SousGroupe, tout_GAC)
 
    element.Value = UCase(CleanTrim(StripAccent(CStr(element.Value))))
 
    Next element
 
'on remplace les numéro de format erroné par les actif
 
    Sheets("Travail").Activate
 
    remplacement_format
 
'enlever les lignes de produit_item si jamais on refais la macro
 
    Worksheets("produits_items").Range("a2:BZ" & LastLignUsedInSheet("produits_items") + 1).Delete
 
'on fais la mise en page a fin d'enlever les lignes ayant des 0 inutilement
 
    mise_en_page_Creation
 
'on nomme la plage de départ de la feuille travail afin de faciliter les filtres
 
    Sheets("Travail").Range(LettreItem & 2).CurrentRegion.Name = "depart_travail"
 
'creation de la feuille filtre pour validation
 
    Sheets.Add.Name = "filtre_item"
 
    With Sheets("filtre_item")
 
    .Range("a1") = Sheets("Travail").Range(LettreItem & 1)
    .Range("b1") = Sheets("Travail").Range(LettreProvLong & 1)
    .Range("c1") = Sheets("Travail").Range(LettreNbProvLong & 1)
    .Range("d1") = Sheets("Travail").Range(LettreProvCourt & 1)
    .Range("e1") = Sheets("Travail").Range(LettreNbProvCourt & 1)
    .Range("f1") = Sheets("Travail").Range(LettreRegLong & 1)
    .Range("g1") = Sheets("Travail").Range(LettreNbRegLong & 1)
    .Range("h1") = Sheets("Travail").Range(LettreRegCourt & 1)
    .Range("i1") = Sheets("Travail").Range(LettreNbRegCourt & 1)
    .Range("j1") = Sheets("Travail").Range(LettreCouleur & 1)
    .Range("k1") = Sheets("Travail").Range(LettreFormat & 1)
    .Range("l1") = Sheets("Travail").Range(LettreGAC & 1)
    .Range("m1") = Sheets("Travail").Range(LettreFamille & 1)
    .Range("n1") = Sheets("Travail").Range(LettreClasse & 1)
    .Range("o1") = Sheets("Travail").Range(LettreGroupe & 1)
    .Range("p1") = Sheets("Travail").Range(LettreSousGroupe & 1)
    .Range("q1") = Sheets("Travail").Range(LettreFCGS & 1)
    .Range("r1") = Sheets("Travail").Range(LettreNumero_de_ligne & 1)
 
'on nomme la plage de destination_filtre afin de facilité le code
 
    .Range("a2").CurrentRegion.Name = "destination_filtre"
 
    'effectuer le filtre
 
    Sheets("Travail").Range("depart_travail").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:= _
    Sheets("filtre_item").Range("A1:q2"), CopyToRange:=Sheets("filtre_item").Range("destination_filtre"), Unique:=True
 
    'défini la plage sur toute la feuille
    Set PlageFiltre = DefPlage(Worksheets("filtre_item"))
 
    'filtre pour ne garder que les lignes ayant seulement rein dans le No d'item
    PlageFiltre.AutoFilter 1, " "
 
    'ajoute une nouvelle feuille
    Set fe = Worksheets.Add
 
    'copie sur la feuille "Feuil2" le résultat du filtrage (cette feuille doit impérativement exister dans le classeur !)
    .AutoFilter.Range.EntireRow.Copy fe.Cells(1, 1)
 
    'suppression du filtre
    PlageFiltre.AutoFilter
 
    'vide la feuille...
    .Cells.Clear
 
    'récupère les valeurs sur la feuille "Feuil2"...
    Set PlageFiltre = DefPlage(fe)
 
    'les colle à nouveau sur la feuille "filtre"
    PlageFiltre.Copy .Cells(1, 1)
 
    'on détruis la feuille créé
    fe.Delete
 
'on nomme la plage de départ afin de faciliter les filtres
 
    .Range("a2").CurrentRegion.Name = "depart_filtre"
 
'on détruis les lignes ayant des 0 dans le nombre de caractère seulement
 
    .Range(Range("A" & LastLignUsedInColumn("B") + 1), Range("R" & LastLignUsedInColumn("B") + 1)).Rows.Delete
 
    End With
 
'on créé une feuille de destination contenant les erreurs
 
    Sheets.Add.Name = "erreur de champs"
 
    With Sheets("erreur de champs")
 
    .Range("a1") = Sheets("Travail").Range(LettreNumero_de_ligne & 1)
    .Range("b1") = Sheets("Travail").Range(LettreProvLong & 1)
    .Range("c1") = Sheets("Travail").Range(LettreNbProvLong & 1)
    .Range("d1") = Sheets("Travail").Range(LettreProvCourt & 1)
    .Range("e1") = Sheets("Travail").Range(LettreNbProvCourt & 1)
    .Range("f1") = Sheets("Travail").Range(LettreRegLong & 1)
    .Range("g1") = Sheets("Travail").Range(LettreNbRegLong & 1)
    .Range("h1") = Sheets("Travail").Range(LettreRegCourt & 1)
    .Range("i1") = Sheets("Travail").Range(LettreNbRegCourt & 1)
    .Range("j1") = Sheets("Travail").Range(LettreCouleur & 1)
    .Range("k1") = Sheets("Travail").Range(LettreFormat & 1)
    .Range("l1") = Sheets("Travail").Range(LettreGAC & 1)
    .Range("m1") = Sheets("Travail").Range(LettreFamille & 1)
    .Range("n1") = Sheets("Travail").Range(LettreClasse & 1)
    .Range("o1") = Sheets("Travail").Range(LettreGroupe & 1)
    .Range("p1") = Sheets("Travail").Range(LettreSousGroupe & 1)
    .Range("q1") = Sheets("Travail").Range(LettreFCGS & 1)
 
    End With
 
'on créé une feuille de critère
 
    Sheets.Add.Name = "critere erreur"
 
'on met les titres d'en-tête
 
    With Sheets("critere erreur")
 
    .Range("a1") = Sheets("Travail").Range(LettreFormat & 1)
    .Range("b1") = Sheets("Travail").Range(LettreCouleur & 1)
    .Range("c1") = Sheets("Travail").Range(LettreProvLong & 1)
    .Range("d1") = Sheets("Travail").Range(LettreRegCourt & 1)
    .Range("e1") = Sheets("Travail").Range(LettreFCGS & 1)
    .Range("f1") = Sheets("Travail").Range(LettreGAC & 1)
    .Range("g1") = Sheets("Travail").Range(LettreProvCourt & 1)
    .Range("h1") = Sheets("Travail").Range(LettreRegLong & 1)
    .Range("i1") = Sheets("Travail").Range(LettreRegCourt & 1)
    .Range("j1") = Sheets("Travail").Range(LettreNbProvLong & 1)
    .Range("k1") = Sheets("Travail").Range(LettreNbProvCourt & 1)
    .Range("l1") = Sheets("Travail").Range(LettreNbRegLong & 1)
    .Range("m1") = Sheets("Travail").Range(LettreNbRegCourt & 1)
    .Range("n1") = Sheets("Travail").Range(LettreGAC & 1)
    .Range("o1") = Sheets("Travail").Range(LettreGAC & 1)
    .Range("p1") = Sheets("Travail").Range(LettreGAC & 1)
    .Range("q1") = Sheets("Travail").Range(LettreGAC & 1)
    .Range("r1") = Sheets("Travail").Range(LettreGAC & 1)
 
'on remplis les critères si le numéro de couleur contient une lettre
 
    .Range("b2") = "*a*"
    .Range("b3") = "*e*"
    .Range("b4") = "*i*"
    .Range("b5") = "*o*"
    .Range("b6") = "*u*"
    .Range("b7") = "*y*"
 
'on remplis les critères si le format contient une lettre
 
    .Range("a8") = "*a*"
    .Range("a9") = "*e*"
    .Range("a10") = "*i*"
    .Range("a11") = "*o*"
    .Range("a12") = "*u*"
    .Range("a13") = "*y*"
    .Range("a14") = "="
 
'on remplis les critères si la provinciale courte est vide
 
    .Range("g15") = "="
 
'on remplis les critères si nombre caractère de la Prov. long est suppérieur a 200
 
    .Range("j16") = ">200"
 
'on remplis les critères si nombre caractère de la Prov. court est suppérieur a 100
 
    .Range("k17") = ">100"
 
'on remplis les critères concernant l'existant de la FCGSG
 
    .Range("e18") = "non"
 
'on remplis les critères concernant la provinciale longue est vide
 
    .Range("c19") = "="
 
'on remplis les critères concernant GAC différent de gaceq, ano, sigma, tous, aucun
 
    .Range("n20") = "<>GACEQ"
    .Range("o20") = "<>ANO"
    .Range("p20") = "<>SIGMA"
    .Range("q20") = "<>AUCUN"
    .Range("r20") = "<>TOUS"
 
'on remplis les critères si GACEQ dont reg long >200
 
    .Range("n21") = "GACEQ"
    .Range("L21") = ">200"
 
'on remplis les critères si ANO dont reg long >200
 
    .Range("n22") = "ANO"
    .Range("L22") = ">200"
 
'on remplis les critères si SIGMA dont reg long >200
 
    .Range("n23") = "SIGMA"
    .Range("L23") = ">200"
 
'on remplis les critères si TOUS dont reg long >200
 
    .Range("n24") = "TOUS"
    .Range("L24") = ">200"
 
'on remplis les critères si GACEQ dont reg court >100
 
    .Range("n25") = "GACEQ"
    .Range("M25") = ">100"
 
'on remplis les critères si ANO dont reg court >100
 
    .Range("n26") = "ANO"
    .Range("M26") = ">100"
 
'on remplis les critères si SIGMA dont reg court >100
 
    .Range("n27") = "SIGMA"
    .Range("M27") = ">100"
 
'on remplis les critères si tous dont reg court >100
 
    .Range("n28") = "TOUS"
    .Range("M28") = ">100"
 
'on remplis les critères si  GACEQ dont reg long est vide
 
    .Range("n29") = "GACEQ"
    .Range("h29") = "="
 
'on remplis les critères si  ANO dont reg long est vide
 
    .Range("n30") = "ANO"
    .Range("h30") = "="
 
 'on remplis les critères si SIGMA dont reg long est vide
 
    .Range("n31") = "SIGMA"
    .Range("h31") = "="
 
'on remplis les critères si  TOUS dont reg long est vide
 
    .Range("n32") = "TOUS"
    .Range("h32") = "="
 
'on remplis les critères si GACEQ dont reg court est vide
 
    .Range("n33") = "GACEQ"
    .Range("i33") = "="
 
'on remplis les critères si  ANO dont reg court est vide
 
    .Range("n34") = "ANO"
    .Range("i34") = "="
 
 'on remplis les critères si SIGMA dont reg court est vide
 
    .Range("n35") = "SIGMA"
    .Range("i35") = "="
 
 'on remplis les critères si TOUS dont reg court est vide
 
    .Range("n36") = "TOUS"
    .Range("i36") = "="
 
'on remplis les critères si le nombre de caractères est vide
 
    .Range("j37") = "="
    .Range("k38") = "="
    .Range("l39") = "="
    .Range("l40") = "="
 
'on nomme la plage de critères
 
    .Range("a2").CurrentRegion.Name = "filtre_elab"
 
'effectuer le filtre
 
    Sheets("filtre_item").Range("depart_filtre").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:= _
    .Range("filtre_elab"), CopyToRange:=Sheets("erreur de champs").Range("a1:q2"), Unique:=True
 
'on détruit la feuille critere erreur qui est maintenant inutile
 
'    .Delete
 
    End With
'on arrete si la feuille erreur de champs contient autre chose que l'entête
 
    If IsEmpty(Sheets("erreur de champs").Range("b2")) = False Then
 
        'on fais une mini mise en page des données afin que le tout sois plus facile a lire et interpréter
 
    With cCreation.Sheets("erreur de champs")
 
        Sheets("Travail").Range("a1").Copy
        .Range("a1:q1").PasteSpecial Paste:=xlPasteFormats
        .Range("B:B,D:D,F:F,H:H").ColumnWidth = 26.67
        .Range("c:c,e:e,g:g,I:I").ColumnWidth = 4.89
        .Range("M:p").ColumnWidth = 2.22
        .Range("B:B,D:D,F:F,H:H").RowHeight = 46.7
        .Range("A1:q1").Interior.Color = RGB(255, 10, 10)
 
'on fais une boucle afin de mettre en évidence les erreurs
 
        For Each cellule In .Range("a2:a" & LastLignUsedInSheet("erreur de champs"))
 
        y = y + 1
 
            If IsEmpty(Cells(y + 1, "b")) Then
               Cells(y + 1, "b").Font.ColorIndex = 3
               Cells(y + 1, "b").Interior.ColorIndex = 34
            End If
 
            If Cells(y + 1, "c") > 200 Then
               Cells(y + 1, "C").Font.ColorIndex = 3
               Cells(y + 1, "C").Interior.ColorIndex = 34
            End If
 
            If IsEmpty(Cells(y + 1, "D")) Then
               Cells(y + 1, "D").Font.ColorIndex = 3
               Cells(y + 1, "D").Interior.ColorIndex = 34
            End If
 
            If Cells(y + 1, "E") > 100 Then
               Cells(y + 1, "E").Font.ColorIndex = 3
               Cells(y + 1, "E").Interior.ColorIndex = 34
            End If
 
            If IsNumeric(Cells(y + 1, "J")) = False Then
               Cells(y + 1, "j").Font.ColorIndex = 3
               Cells(y + 1, "j").Interior.ColorIndex = 34
            End If
 
            If IsNumeric(Cells(y + 1, "k")) = False Then
               Cells(y + 1, "k").Font.ColorIndex = 3
               Cells(y + 1, "k").Interior.ColorIndex = 34
            End If
 
            If IsEmpty(Cells(y + 1, "k")) Then
               Cells(y + 1, "k").Font.ColorIndex = 3
               Cells(y + 1, "k").Interior.ColorIndex = 34
            End If
 
            If Cells(y + 1, "l") <> "GACEQ" And Cells(y + 1, "l") <> "ANO" And Cells(y + 1, "l") <> "SIGMA" _
                                            And Cells(y + 1, "l") <> "TOUS" And Cells(y + 1, "l") <> "AUCUN" Then
               Cells(y + 1, "L").Font.ColorIndex = 3
               Cells(y + 1, "L").Interior.ColorIndex = 34
            End If
 
            If Cells(y + 1, "Q") = "non" Then
               Cells(y + 1, "q").Font.ColorIndex = 3
               Cells(y + 1, "q").Interior.ColorIndex = 34
            End If
 
            If (Cells(y + 1, "l") = "GACEQ" Or Cells(y + 1, "l") = "ANO" Or Cells(y + 1, "l") = "SIGMA" Or Cells(y + 1, "l") = "TOUS") _
            And IsEmpty(Cells(y + 1, "F")) Then
               Cells(y + 1, "F").Font.ColorIndex = 3
               Cells(y + 1, "F").Interior.ColorIndex = 34
            End If
 
            If (Cells(y + 1, "l") = "GACEQ" Or Cells(y + 1, "l") = "ANO" Or Cells(y + 1, "l") = "SIGMA" Or Cells(y + 1, "l") = "TOUS") _
            And IsEmpty(Cells(y + 1, "H")) Then
               Cells(y + 1, "H").Font.ColorIndex = 3
               Cells(y + 1, "H").Interior.ColorIndex = 34
            End If
 
            If (Cells(y + 1, "l") = "GACEQ" Or Cells(y + 1, "l") = "ANO" Or Cells(y + 1, "l") = "SIGMA" Or Cells(y + 1, "l") = "TOUS") _
            And Cells(y + 1, "G") > 200 Then
               Cells(y + 1, "G").Font.ColorIndex = 3
               Cells(y + 1, "G").Interior.ColorIndex = 34
            End If
 
            If (Cells(y + 1, "l") = "GACEQ" Or Cells(y + 1, "l") = "ANO" Or Cells(y + 1, "l") = "SIGMA" Or Cells(y + 1, "l") = "TOUS") _
            And Cells(y + 1, "I") > 100 Then
               Cells(y + 1, "I").Font.ColorIndex = 3
               Cells(y + 1, "I").Interior.ColorIndex = 34
            End If
 
        Next cellule
 
        'on copy la feuille d'erreur dans un autre fichier
 
        .Copy
 
        'on détruis la feuille filtre_item, active la feuille d'erreur, on affiche un message et exit
 
'        cCreation.Sheets("filtre_item").Delete
        .Delete
        MsgBox "Corriger les erreurs sur les lignes suivantes", vbCritical
 
        Exit Sub
 
    End With
 
    Else
'        Sheets("erreur de champs").Delete
 
    End If
 
'on nomme les plage de la feuille filtre_item afin de faciliter le travail
 
    With Sheets("filtre_item")
 
    .Range("b2:b" & LastLignUsedInColumn("B")).Name = "filtre_prov_long"
    .Range("d2:d" & LastLignUsedInColumn("d")).Name = "filtre_prov_court"
    .Range("f2:f" & LastLignUsedInColumn("f")).Name = "filtre_reg_long"
    .Range("h2:h" & LastLignUsedInColumn("h")).Name = "filtre_reg_long"
    .Range("j2:j" & LastLignUsedInColumn("b")).Name = "filtre_couleur"
    .Range("k2:k" & LastLignUsedInColumn("k")).Name = "filtre_format"
    .Range("l2:l" & LastLignUsedInColumn("l")).Name = "filtre_GAC"
    .Range("m2:m" & LastLignUsedInColumn("m")).Name = "filtre_F"
    .Range("n2:n" & LastLignUsedInColumn("n")).Name = "filtre_C"
    .Range("o2:o" & LastLignUsedInColumn("o")).Name = "filtre_G"
    .Range("p2:p" & LastLignUsedInColumn("p")).Name = "filtre_S"
 
 
'on copie les plages "fixes" de la feuille filtre_item dans la feuille produits_items
 
    .Range("filtre_prov_long").Copy Sheets("produits_items").Range("c2")
    .Range("filtre_prov_court").Copy Sheets("produits_items").Range("d2")
    .Range("filtre_F").Copy Sheets("produits_items").Range("p2")
    .Range("filtre_C").Copy Sheets("produits_items").Range("q2")
    .Range("filtre_G").Copy Sheets("produits_items").Range("R2")
    .Range("filtre_S").Copy Sheets("produits_items").Range("S2")
    .Range("filtre_format").Copy Sheets("produits_items").Range("ab2")
    .Range("filtre_couleur").Copy Sheets("produits_items").Range("aa2")
 
    End With
 
'on copie les plages necessitant un autofill arpes la saisie
 
    With Sheets("produits_items")
 
    .Range("l2") = "TRUE"
    .Range("m2") = "TRUE"
    .Range("b2") = "P"
    .Range("u2") = "P"
    .Range("n2") = "=IF(RC[2]=80,""S"",""P"")"
 
    End With
 
'on fait les autofill si il y a plus qu'une ligne
 
 If LastLignUsedInColumn("b") > 2 Then
 
    With Sheets("produits_items")
 
    .Range("l2").AutoFill Destination:=.Range("l2:l" & LastLignUsedInSheet("produits_items"))
    .Range("m2").AutoFill Destination:=.Range("m2:m" & LastLignUsedInSheet("produits_items"))
    .Range("b2").AutoFill Destination:=.Range("b2:b" & LastLignUsedInSheet("produits_items"))
    .Range("u2").AutoFill Destination:=.Range("u2:u" & LastLignUsedInSheet("produits_items"))
    .Range("n2").AutoFill Destination:=.Range("n2:n" & LastLignUsedInSheet("produits_items"))
 
    End With
 
 End If
 
'on copie la valeur de l'autofill du code_type_produit
 
    With Sheets("produits_items")
 
    .Range("n2:n" & LastLignUsedInSheet("produits_items")).Value = _
    .Range("n2:n" & LastLignUsedInSheet("produits_items")).Value
 
    End With
 
'on selection la feuille filtre_item afin de mieux partir la boucle
 
    Sheets("filtre_item").Select
 
 
'on fait la boucle sur la feuille filtre afin de remplir les regionnales dans la feuille produits_items
 
    For Each cell In Sheets("filtre_item").Range("b2:b" & LastLignUsedInSheet("filtre_item"))
 
            x = x + 1
 
'si le gac ayant régionale est GACEQ
 
 
        If Cells(x + 1, 12) = "GACEQ" Then
 
          With Sheets("produits_items")
 
            'on copie la régionale longue dans a cellule correspondante dans la feuille produits_items
 
            .Cells(x + 1, [desc_reg_gaceq_pi].Column) = Sheets("filtre_item").Cells(x + 1, 6)
 
            'on copie la régionale courte dans a cellule correspondante dans la feuille produits_items
 
            .Cells(x + 1, [desc_reg_court_gaceq_pi].Column) = Sheets("filtre_item").Cells(x + 1, 8)
 
            'on copie la provinciale longue dans desc_reg_gacouest et desc_reg_sigmasante
 
            Union(.Cells(x + 1, [desc_reg_gacouest_pi].Column), _
            .Cells(x + 1, [desc_reg_sigmasante_pi].Column)) = Sheets("filtre_item").Cells(x + 1, 2)
 
            'on copie provinciale courte dans desc_reg_court_gacouest et desc_reg_court_sigmasante
 
            Union(.Cells(x + 1, [desc_reg_court_gacouest_pi].Column), _
            .Cells(x + 1, [desc_reg_court_sigmasante_pi].Column)) = Sheets("filtre_item").Cells(x + 1, 4)
 
          End With
 
'si le gac ayant régionale est ANO
 
        ElseIf Cells(x + 1, 12) = "ANO" Then
 
          With Sheets("produits_items")
 
            'Si ANO copie régionale longue dans desc_reg_gacouest
 
            .Cells(x + 1, [desc_reg_gacouest_pi].Column) = Sheets("filtre_item").Cells(x + 1, 6)
 
            'Si ANO copie régionale courte dans desc_reg_court_gacouest
 
            .Cells(x + 1, [desc_reg_court_gacouest_pi].Column) = Sheets("filtre_item").Cells(x + 1, 8)
 
            'Si ANO copie provinciale longue dans desc_reg_gaceq et desc_reg_sigmasante
 
            Union(.Cells(x + 1, [desc_reg_gaceq_pi].Column), _
            .Cells(x + 1, [desc_reg_sigmasante_pi].Column)) = Sheets("filtre_item").Cells(x + 1, 2)
 
            'Si ANO copie provinciale courte dans desc_reg_court_gaceq et desc_reg_court_sigmasante
 
            Union(.Cells(x + 1, [desc_reg_court_gaceq_pi].Column), _
            .Cells(x + 1, [desc_reg_court_sigmasante_pi].Column)) = Sheets("filtre_item").Cells(x + 1, 4)
 
          End With
 
'si le gac ayant régionale est SIGMA
 
         ElseIf Cells(x + 1, 12) = "SIGMA" Then
 
           With Sheets("produits_items")
 
            'Si SIGMA copie régionale longue dans desc_reg_sigmasante
 
            .Cells(x + 1, [desc_reg_sigmasante_pi].Column) = Sheets("filtre_item").Cells(x + 1, 6)
 
            'Si SIGMA copie régionale courte dans desc_reg_court_sigmasante
 
            .Cells(x + 1, [desc_reg_court_sigmasante_pi].Column) = Sheets("filtre_item").Cells(x + 1, 8)
 
            'Si SIGMA copie provinciale longue dans desc_reg_gaceq et desc_reg_gacouest
 
            Union(.Cells(x + 1, [desc_reg_gaceq_pi].Column), _
            .Cells(x + 1, [desc_reg_gacouest_pi].Column)) = Sheets("filtre_item").Cells(x + 1, 2)
 
            'Si SIGMA copie provinciale courte dans desc_reg_court_gaceq et desc_reg_court_gacouest
 
            Union(.Cells(x + 1, [desc_reg_court_gaceq_pi].Column), _
            .Cells(x + 1, [desc_reg_court_gacouest_pi].Column)) = Sheets("filtre_item").Cells(x + 1, 4)
 
          End With
 
'si le gac ayant régionale est AUCUN
 
         ElseIf Cells(x + 1, 12) = "AUCUN" Then
 
          With Sheets("produits_items")
 
            'Si "aucun" copie provinciale longue dans desc_reg_gaceq, desc_reg_gacouest et desc_reg_sigmasante
 
            Union(.Cells(x + 1, [desc_reg_gaceq_pi].Column), _
            .Cells(x + 1, [desc_reg_gacouest_pi].Column), _
            .Cells(x + 1, [desc_reg_sigmasante_pi].Column)) = Sheets("filtre_item").Cells(x + 1, 2)
 
 
            'Si "aucun" copie provinciale courte dans desc_reg_court_gaceq, desc_reg_court_gacouest et desc_reg_court_sigmasante
 
            Union(.Cells(x + 1, [desc_reg_court_gaceq_pi].Column), _
            .Cells(x + 1, [desc_reg_court_gacouest_pi].Column), _
            .Cells(x + 1, [desc_reg_court_sigmasante_pi].Column)) = Sheets("filtre_item").Cells(x + 1, 4)
 
          End With
 
'si le gac ayant régionale est TOUS
 
         ElseIf Cells(x + 1, 12) = "TOUS" Then
 
           With Sheets("produits_items")
 
            'Si TOUS copie régionale longue dans desc_reg_gacouest_pi, desc_reg_gaceq_pi, desc_reg_sigmasante_pi
 
            Union(.Cells(x + 1, [desc_reg_gacouest_pi].Column), _
            .Cells(x + 1, [desc_reg_gaceq_pi].Column), _
            .Cells(x + 1, [desc_reg_sigmasante_pi].Column)) = Sheets("filtre_item").Cells(x + 1, 6)
 
            'Si TOUS copie régionale courte dans desc_reg_court_gaceq_pi,desc_reg_court_gacouest_pi,desc_reg_court_sigmasante_pi
 
            Union(.Cells(x + 1, [desc_reg_court_gacouest_pi].Column), _
            .Cells(x + 1, [desc_reg_court_gaceq_pi].Column), _
            .Cells(x + 1, [desc_reg_court_sigmasante_pi].Column)) = Sheets("filtre_item").Cells(x + 1, 8)
 
          End With
 
         End If
 
    Next cell
 
'on detruit la feuille "filtre_item"
'    Sheets("filtre_item").Delete
 
'on pointe sur la feuille produits_items
    Sheets("produits_items").Activate
 
'sauvegarder le document
    ActiveWorkbook.Save
 
'reactiver le display et le screen updating
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
 
 
End Sub

Je suis en train de modifié un autre code en faisant le même principe pour un autre type de fichier.

Le seul hic c'Est que j'ai toujours un erreur d'exécution '1004' : Le nom de champ est incorrect ou manquant dans la zone d'extraction malgré du faits que ça fais plus de 3 heures que j'essaie de trouvé ce qui cloche.

Voici donc le code que je suis en train d'adapter (il y a des colonnes portant d'autre nom que le fichier originale, que j'ai remplacé)

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
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
Sub test_copiedansproduit_modif_provinciale()

Dim x As Long
Dim cell As Variant

Dim y As Long
Dim cellule As Variant

Dim element As Variant

Dim LettreExecution As String
Dim LettreNoProduit As String
Dim LettreNoItem As String
Dim LettreNoMandat As String
Dim LettreAncProvLong As String
Dim LettreMandatLac As String
Dim LettreNbProvLong As String
Dim LettreProvLong As String
Dim LettreNbProvCourt As String
Dim LettreProvCourt As String
Dim LettreNbRegLong As String
Dim LettreRegLong As String
Dim LettreNbRegCourt As String
Dim LettreRegCourt As String
Dim LettreF As String
Dim LettreC As String
Dim LettreG As String
Dim LettreSG As String
Dim LettreGAC As String
Dim LettreCombin As String
Dim LettreExist As String
Dim LettreNoLigne As String

Dim PlageFiltre As Range
    
Dim fe As Worksheet
    
Dim cCreation As Workbook
Set cCreation = ActiveWorkbook

Dim tout_execute As Range

LettreExecution = TrouveLettreColonne([execution])
LettreNoProduit = TrouveLettreColonne([no_produit_travail])
LettreNoItem = TrouveLettreColonne([no_item_travail])
LettreNoMandat = TrouveLettreColonne([no_mandat])
LettreAncProvLong = TrouveLettreColonne([ancienne_prov_longue])
LettreMandatLac = TrouveLettreColonne([mandat_lac])
LettreProvLong = TrouveLettreColonne([prov_long_travail])
LettreProvCourt = TrouveLettreColonne([prov_court_travail])
LettreRegLong = TrouveLettreColonne([reg_long_travail])
LettreRegCourt = TrouveLettreColonne([reg_court_travail])
LettreF = TrouveLettreColonne([f_travail])
LettreC = TrouveLettreColonne([c_travail])
LettreG = TrouveLettreColonne([g_travail])
LettreSG = TrouveLettreColonne([sg_travail])
LettreGAC = TrouveLettreColonne([gac_travail])
LettreCombin = TrouveLettreColonne([combin_FCGS])
LettreExist = TrouveLettreColonne([fcgs_exist_travail])
LettreNoLigne = TrouveLettreColonne([numero_de_ligne])
LettreNbProvLong = TrouveLettreColonne([nb_prov_long])
LettreNbProvCourt = TrouveLettreColonne([nb_prov_court])
LettreNbRegLong = TrouveLettreColonne([nb_reg_long])
LettreNbRegCourt = TrouveLettreColonne([nb_reg_court])


Set tout_execute = Worksheets("Travail").Range(LettreExecution & 2, LettreExecution & LastLignUsedInColumn(LettreExecution) + 1)


'Application.ScreenUpdating = False
Application.DisplayAlerts = False


'valider si les feuilles data et catalogue sont existante sinon erreur
If sheetExists("catalogue") = True And sheetExists("data") = True And sheetExists("FCG") = True Then
    Else
    MsgBox "feuille data et/ou catalogue manquante, faire un update !!! ", vbCritical
    Exit Sub
End If

If sheetExists("filtre_item") Then Sheets("filtre_item").Delete
If sheetExists("erreur de champs") Then Sheets("erreur de champs").Delete
If sheetExists("critere erreur") Then Sheets("critere erreur").Delete


'enlever les lignes de produit_item si jamais on refais la macro

    Worksheets("produit").Range("a2:BZ" & LastLignUsedInSheet("produit") + 1).Delete

'nettoyer les lignes critiques afin d'enlever les caractères spéciaux

    For Each element In tout_execute

    element.Value = UCase(StripAccent(CleanTrim(CStr(element.Value))))

    Next element

'on fais la mise en page a fin d'enlever les lignes ayant des 0 inutilement

    mise_en_page_Modif_Prov

'on nomme la plage de départ de la feuille travail afin de faciliter les filtres

    Sheets("Travail").Range(LettreExecution & 2).CurrentRegion.Name = "depart_travail"

'creation de la feuille filtre pour validation

    Sheets.Add.Name = "filtre_item"
    
    With Sheets("filtre_item")
    
    .Range("a1") = Sheets("Travail").Range(LettreExecution & 1)
    .Range("b1") = Sheets("Travail").Range(LettreNoProduit & 1)
    .Range("c1") = Sheets("Travail").Range(LettreNoItem & 1)
    .Range("d1") = Sheets("Travail").Range(LettreNoMandat & 1)
    .Range("e1") = Sheets("Travail").Range(LettreProvLong & 1)
    .Range("f1") = Sheets("Travail").Range(LettreNbProvLong & 1)
    .Range("g1") = Sheets("Travail").Range(LettreProvCourt & 1)
    .Range("h1") = Sheets("Travail").Range(LettreNbProvCourt & 1)
    .Range("i1") = Sheets("Travail").Range(LettreRegLong & 1)
    .Range("j1") = Sheets("Travail").Range(LettreNbRegLong & 1)
    .Range("k1") = Sheets("Travail").Range(LettreRegCourt & 1)
    .Range("l1") = Sheets("Travail").Range(LettreNbRegCourt & 1)
    .Range("m1") = Sheets("Travail").Range(LettreF & 1)
    .Range("n1") = Sheets("Travail").Range(LettreC & 1)
    .Range("o1") = Sheets("Travail").Range(LettreG & 1)
    .Range("p1") = Sheets("Travail").Range(LettreSG & 1)
    .Range("q1") = Sheets("Travail").Range(LettreCombin & 1)
    .Range("r1") = Sheets("Travail").Range(LettreNoLigne & 1)
   

'on nomme la plage de destination_filtre afin de facilité le code
    
    .Range("a2").CurrentRegion.Name = "destination_filtre"

    'effectuer le filtre

    Sheets("Travail").Range("depart_travail").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:= _
    Sheets("filtre_item").Range("A1:r2"), CopyToRange:=Sheets("filtre_item").Range("destination_filtre"), Unique:=True
   
    'défini la plage sur toute la feuille
    Set PlageFiltre = DefPlage(Worksheets("filtre_item"))
 
    'filtre pour ne garder que les lignes ayant seulement rein dans le No d'item
    PlageFiltre.AutoFilter 1, "X"
 
    'ajoute une nouvelle feuille
    Set fe = Worksheets.Add
 
    'copie sur la feuille "Feuil2" le résultat du filtrage (cette feuille doit impérativement exister dans le classeur !)
    .AutoFilter.Range.EntireRow.Copy fe.Cells(1, 1)
 
    'suppression du filtre
    PlageFiltre.AutoFilter
 
    'vide la feuille...
    .Cells.Clear
 
    'récupère les valeurs sur la feuille "Feuil2"...
    Set PlageFiltre = DefPlage(fe)
 
    'les colle à nouveau sur la feuille "filtre"
    PlageFiltre.Copy .Cells(1, 1)

    'on détruis la feuille créé
    fe.Delete
    
'on nomme la plage de départ afin de faciliter les filtres

    .Range("a2").CurrentRegion.Name = "depart_filtre"
    
    End With
    
'on créé une feuille de destination contenant les erreurs

    Sheets.Add.Name = "erreur de champs"

    With Sheets("erreur de champs")
    
    .Range("a1") = Sheets("Travail").Range(LettreNoLigne & 1)
    .Range("b1") = Sheets("Travail").Range(LettreProvLong & 1)
    .Range("c1") = Sheets("Travail").Range(LettreNbProvLong & 1)
    .Range("d1") = Sheets("Travail").Range(LettreProvCourt & 1)
    .Range("e1") = Sheets("Travail").Range(LettreNbProvCourt & 1)
    .Range("f1") = Sheets("Travail").Range(LettreRegLong & 1)
    .Range("g1") = Sheets("Travail").Range(LettreNbRegLong & 1)
    .Range("h1") = Sheets("Travail").Range(LettreRegCourt & 1)
    .Range("i1") = Sheets("Travail").Range(LettreNbRegCourt & 1)
    .Range("j1") = Sheets("Travail").Range(LettreGAC & 1)
    .Range("k1") = Sheets("Travail").Range(LettreF & 1)
    .Range("l1") = Sheets("Travail").Range(LettreC & 1)
    .Range("m1") = Sheets("Travail").Range(LettreG & 1)
    .Range("n1") = Sheets("Travail").Range(LettreSG & 1)
    .Range("o1") = Sheets("Travail").Range(LettreCombin & 1)

    End With
    
'on créé une feuille de critère

    Sheets.Add.Name = "critere erreur"

'on met les titres d'en-tête
    
    With Sheets("critere erreur")
    
    .Range("a1") = Sheets("Travail").Range(LettreProvLong & 1)
    .Range("b1") = Sheets("Travail").Range(LettreRegCourt & 1)
    .Range("c1") = Sheets("Travail").Range(LettreCombin & 1)
    .Range("d1") = Sheets("Travail").Range(LettreGAC & 1)
    .Range("e1") = Sheets("Travail").Range(LettreProvCourt & 1)
    .Range("f1") = Sheets("Travail").Range(LettreRegLong & 1)
    .Range("g1") = Sheets("Travail").Range(LettreNbProvLong & 1)
    .Range("h1") = Sheets("Travail").Range(LettreNbProvCourt & 1)
    .Range("i1") = Sheets("Travail").Range(LettreNbRegLong & 1)
    .Range("j1") = Sheets("Travail").Range(LettreNbRegCourt & 1)
    
'on remplis les critères si la provinciale courte est vide
    
    .Range("e2") = "="

'on remplis les critères si nombre caractère de la Prov. long est suppérieur a 200
    
    .Range("g3") = ">200"

'on remplis les critères si nombre caractère de la Prov. court est suppérieur a 100
    
    .Range("h4") = ">100"
    
'on remplis les critères concernant l'existant de la FCGSG

    .Range("c5") = "non"
    
'on remplis les critères concernant la provinciale longue est vide

    .Range("a6") = "="
       
'on remplis les critères si gaceq-ANCIEN dont reg long >200
    
    .Range("d7") = "gaceq-ANCIEN"
    .Range("i7") = ">200"
          
'on remplis les critères si ano-ANCIEN dont reg long >200
    
    .Range("d8") = "ano-ANCIEN"
    .Range("i8") = ">200"

'on remplis les critères si sigma-ANCIEN dont reg long >200
    
    .Range("d9") = "sigma-ANCIEN"
    .Range("i9") = ">200"

'on remplis les critères si tous dont reg long >200
    
    .Range("d10") = "tous"
    .Range("i10") = ">200"

'on remplis les critères si gaceq-PROV dont reg long >200
    
    .Range("d11") = "gaceq-PROV"
    .Range("i11") = ">200"

'on remplis les critères si ano-PROV dont reg long >200
    
    .Range("d12") = "ano-PROV"
    .Range("i12") = ">200"

'on remplis les critères si sigma-PROV dont reg long >200
    
    .Range("d13") = "sigma-PROV"
    .Range("i13") = ">200"
   
'on remplis les critères si gaceq-ANCIEN dont reg court >100
    
    .Range("d14") = "gaceq-ANCIEN"
    .Range("j14") = ">100"
          
'on remplis les critères si ano-ANCIEN dont reg court >100
    
    .Range("d15") = "ano-ANCIEN"
    .Range("j15") = ">100"

'on remplis les critères si sigma-ANCIEN dont reg court >100
    
    .Range("d16") = "sigma-ANCIEN"
    .Range("j16") = ">100"

'on remplis les critères si tous dont reg court >100
    
    .Range("d17") = "tous"
    .Range("j17") = ">100"

'on remplis les critères si gaceq-PROV dont reg court >100
    
    .Range("d18") = "gaceq-PROV"
    .Range("j18") = ">100"

'on remplis les critères si ano-PROV dont reg court >100
    
    .Range("d19") = "ano-PROV"
    .Range("j19") = ">100"

'on remplis les critères si sigma-PROV dont reg court >100
    
    .Range("d20") = "sigma-PROV"
    .Range("j20") = ">100"
       
'on remplis les critères si gaceq-ANCIEN dont reg court est vide
    
    .Range("d21") = "gaceq-ANCIEN"
    .Range("b21") = "="
          
'on remplis les critères si ano-ANCIEN dont reg court est vide
    
    .Range("d22") = "ano-ANCIEN"
    .Range("b22") = "="

'on remplis les critères si sigma-ANCIEN dont reg court est vide
    
    .Range("d23") = "sigma-ANCIEN"
    .Range("b23") = "="

'on remplis les critères si tous dont reg court est vide
    
    .Range("d24") = "tous"
    .Range("b24") = "="

'on remplis les critères si gaceq-PROV dont reg court est vide
    
    .Range("d25") = "gaceq-PROV"
    .Range("b25") = "="

'on remplis les critères si ano-PROV dont reg court est vide
    
    .Range("d26") = "ano-PROV"
    .Range("b26") = "="

'on remplis les critères si sigma-PROV dont reg court est vide
    
    .Range("d27") = "sigma-PROV"
    .Range("b27") = "="

'on remplis les critères si gaceq-ANCIEN dont reg long est vide
    
    .Range("d28") = "gaceq-ANCIEN"
    .Range("f28") = "="
          
'on remplis les critères si ano-ANCIEN dont reg long est vide
    
    .Range("d29") = "ano-ANCIEN"
    .Range("f29") = "="

'on remplis les critères si sigma-ANCIEN dont reg long est vide
    
    .Range("d30") = "sigma-ANCIEN"
    .Range("f30") = "="

'on remplis les critères si tous dont reg long est vide
    
    .Range("d31") = "tous"
    .Range("f31") = "="

'on remplis les critères si gaceq-PROV dont reg long est vide
    
    .Range("d32") = "gaceq-PROV"
    .Range("f32") = "="

'on remplis les critères si ano-PROV dont reg long est vide
    
    .Range("d33") = "ano-PROV"
    .Range("f33") = "="

'on remplis les critères si sigma-PROV dont reg long est vide
    
    .Range("d34") = "sigma-PROV"
    .Range("f34") = "="

'on remplis les critères si le nombre de caractères est vide

    .Range("g35") = "="
    .Range("h36") = "="
    .Range("i37") = "="
    .Range("j38") = "="
    

'on nomme la plage de critères
    
    .Range("a2").CurrentRegion.Name = "filtre_elab"

'effectuer le filtre


    Sheets("filtre_item").Range("depart_filtre").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:= _
    .Range("filtre_elab"), CopyToRange:=Sheets("erreur de champs").Range("a1:q2"), Unique:=True





'on détruit la feuille critere erreur qui est maintenant inutile

    .Delete

    End With
'on arrete si la feuille erreur de champs contient autre chose que l'entête
    
    If IsEmpty(Sheets("erreur de champs").Range("b2")) = False Then
        
        'on fais une mini mise en page des données afin que le tout sois plus facile a lire et interpréter
    
    With cCreation.Sheets("erreur de champs")
        
        Sheets("Travail").Range("a1").Copy
        .Range("a1:q1").PasteSpecial Paste:=xlPasteFormats
        .Range("B:B,D:D,F:F,H:H").ColumnWidth = 26.67
        .Range("c:c,e:e,g:g,I:I").ColumnWidth = 4.89
        .Range("M:p").ColumnWidth = 2.22
        .Range("B:B,D:D,F:F,H:H").RowHeight = 46.7
        .Range("A1:q1").Interior.Color = RGB(255, 10, 10)
        
'on fais une boucle afin de mettre en évidence les erreurs
        
        For Each cellule In .Range("a2:a" & LastLignUsedInSheet("erreur de champs"))
        
        y = y + 1
        
            If IsEmpty(Cells(y + 1, "b")) Then
               Cells(y + 1, "b").Font.ColorIndex = 3
               Cells(y + 1, "b").Interior.ColorIndex = 34
            End If
               
            If Cells(y + 1, "c") > 200 Then
               Cells(y + 1, "C").Font.ColorIndex = 3
               Cells(y + 1, "C").Interior.ColorIndex = 34
            End If
            
            If IsEmpty(Cells(y + 1, "D")) Then
               Cells(y + 1, "D").Font.ColorIndex = 3
               Cells(y + 1, "D").Interior.ColorIndex = 34
            End If
            
            If Cells(y + 1, "E") > 100 Then
               Cells(y + 1, "E").Font.ColorIndex = 3
               Cells(y + 1, "E").Interior.ColorIndex = 34
            End If
            
            If IsNumeric(Cells(y + 1, "J")) = False Then
               Cells(y + 1, "j").Font.ColorIndex = 3
               Cells(y + 1, "j").Interior.ColorIndex = 34
            End If
            
            If IsNumeric(Cells(y + 1, "k")) = False Then
               Cells(y + 1, "k").Font.ColorIndex = 3
               Cells(y + 1, "k").Interior.ColorIndex = 34
            End If
            
            If IsEmpty(Cells(y + 1, "k")) Then
               Cells(y + 1, "k").Font.ColorIndex = 3
               Cells(y + 1, "k").Interior.ColorIndex = 34
            End If
                      
            If Cells(y + 1, "l") <> "GACEQ" And Cells(y + 1, "l") <> "ANO" And Cells(y + 1, "l") <> "SIGMA" _
                                            And Cells(y + 1, "l") <> "TOUS" And Cells(y + 1, "l") <> "AUCUN" Then
               Cells(y + 1, "L").Font.ColorIndex = 3
               Cells(y + 1, "L").Interior.ColorIndex = 34
            End If
            
            If Cells(y + 1, "Q") = "non" Then
               Cells(y + 1, "q").Font.ColorIndex = 3
               Cells(y + 1, "q").Interior.ColorIndex = 34
            End If
            
            If (Cells(y + 1, "l") = "GACEQ" Or Cells(y + 1, "l") = "ANO" Or Cells(y + 1, "l") = "SIGMA" Or Cells(y + 1, "l") = "TOUS") _
            And IsEmpty(Cells(y + 1, "F")) Then
               Cells(y + 1, "F").Font.ColorIndex = 3
               Cells(y + 1, "F").Interior.ColorIndex = 34
            End If
            
            If (Cells(y + 1, "l") = "GACEQ" Or Cells(y + 1, "l") = "ANO" Or Cells(y + 1, "l") = "SIGMA" Or Cells(y + 1, "l") = "TOUS") _
            And IsEmpty(Cells(y + 1, "H")) Then
               Cells(y + 1, "H").Font.ColorIndex = 3
               Cells(y + 1, "H").Interior.ColorIndex = 34
            End If
            
            If (Cells(y + 1, "l") = "GACEQ" Or Cells(y + 1, "l") = "ANO" Or Cells(y + 1, "l") = "SIGMA" Or Cells(y + 1, "l") = "TOUS") _
            And Cells(y + 1, "G") > 200 Then
               Cells(y + 1, "G").Font.ColorIndex = 3
               Cells(y + 1, "G").Interior.ColorIndex = 34
            End If
            
            If (Cells(y + 1, "l") = "GACEQ" Or Cells(y + 1, "l") = "ANO" Or Cells(y + 1, "l") = "SIGMA" Or Cells(y + 1, "l") = "TOUS") _
            And Cells(y + 1, "I") > 100 Then
               Cells(y + 1, "I").Font.ColorIndex = 3
               Cells(y + 1, "I").Interior.ColorIndex = 34
            End If
            
        Next cellule
        
        'on copy la feuille d'erreur dans un autre fichier
        
        .Copy
        
        'on détruis la feuille filtre_item, active la feuille d'erreur, on affiche un message et exit
        
        cCreation.Sheets("filtre_item").Delete
        .Delete
        MsgBox "Corriger les erreurs sur les lignes suivantes", vbCritical
        
        Exit Sub
      
    End With
    
    Else
        Sheets("erreur de champs").Delete
    
    End If

'on nomme les plage de la feuille filtre_item afin de faciliter le travail

    With Sheets("filtre_item")

    .Range("b2:b" & LastLignUsedInColumn("B")).Name = "filtre_prov_long"
    .Range("d2:d" & LastLignUsedInColumn("d")).Name = "filtre_prov_court"
    .Range("f2:f" & LastLignUsedInColumn("f")).Name = "filtre_reg_long"
    .Range("h2:h" & LastLignUsedInColumn("h")).Name = "filtre_reg_long"
    .Range("j2:j" & LastLignUsedInColumn("b")).Name = "filtre_couleur"
    .Range("k2:k" & LastLignUsedInColumn("k")).Name = "filtre_format"
    .Range("l2:l" & LastLignUsedInColumn("l")).Name = "filtre_GAC"
    .Range("m2:m" & LastLignUsedInColumn("m")).Name = "filtre_F"
    .Range("n2:n" & LastLignUsedInColumn("n")).Name = "filtre_C"
    .Range("o2:o" & LastLignUsedInColumn("o")).Name = "filtre_G"
    .Range("p2:p" & LastLignUsedInColumn("p")).Name = "filtre_S"

  
'on copie les plages "fixes" de la feuille filtre_item dans la feuille produits_items
    
    .Range("filtre_prov_long").Copy Sheets("produits_items").Range("c2")
    .Range("filtre_prov_court").Copy Sheets("produits_items").Range("d2")
    .Range("filtre_F").Copy Sheets("produits_items").Range("p2")
    .Range("filtre_C").Copy Sheets("produits_items").Range("q2")
    .Range("filtre_G").Copy Sheets("produits_items").Range("R2")
    .Range("filtre_S").Copy Sheets("produits_items").Range("S2")
    .Range("filtre_format").Copy Sheets("produits_items").Range("ab2")
    .Range("filtre_couleur").Copy Sheets("produits_items").Range("aa2")
    
    End With
    
'on copie les plages necessitant un autofill arpes la saisie
    
    With Sheets("produits_items")
    
    .Range("l2") = "TRUE"
    .Range("m2") = "TRUE"
    .Range("b2") = "P"
    .Range("u2") = "P"
    .Range("n2") = "=IF(RC[2]=80,""S"",""P"")"

    End With

'on fait les autofill si il y a plus qu'une ligne

 If LastLignUsedInColumn("b") > 2 Then
    
    With Sheets("produits_items")

    .Range("l2").AutoFill Destination:=.Range("l2:l" & LastLignUsedInSheet("produits_items"))
    .Range("m2").AutoFill Destination:=.Range("m2:m" & LastLignUsedInSheet("produits_items"))
    .Range("b2").AutoFill Destination:=.Range("b2:b" & LastLignUsedInSheet("produits_items"))
    .Range("u2").AutoFill Destination:=.Range("u2:u" & LastLignUsedInSheet("produits_items"))
    .Range("n2").AutoFill Destination:=.Range("n2:n" & LastLignUsedInSheet("produits_items"))
 
    End With
 
 End If
    
'on copie la valeur de l'autofill du code_type_produit
    
    With Sheets("produits_items")
    
    .Range("n2:n" & LastLignUsedInSheet("produits_items")).Value = _
    .Range("n2:n" & LastLignUsedInSheet("produits_items")).Value

    End With

'on selection la feuille filtre_item afin de mieux partir la boucle
    
    Sheets("filtre_item").Select


'on fait la boucle sur la feuille filtre afin de remplir les regionnales dans la feuille produits_items

    For Each cell In Sheets("filtre_item").Range("b2:b" & LastLignUsedInSheet("filtre_item"))

            x = x + 1

'si le gac ayant régionale est GACEQ


        If Cells(x + 1, 12) = "GACEQ" Then
            
          With Sheets("produits_items")
            
            'on copie la régionale longue dans a cellule correspondante dans la feuille produits_items

            .Cells(x + 1, [desc_reg_gaceq_pi].Column) = Sheets("filtre_item").Cells(x + 1, 6)
    
            'on copie la régionale courte dans a cellule correspondante dans la feuille produits_items
            
            .Cells(x + 1, [desc_reg_court_gaceq_pi].Column) = Sheets("filtre_item").Cells(x + 1, 8)
            
            'on copie la provinciale longue dans desc_reg_gacouest et desc_reg_sigmasante

            Union(.Cells(x + 1, [desc_reg_gacouest_pi].Column), _
            .Cells(x + 1, [desc_reg_sigmasante_pi].Column)) = Sheets("filtre_item").Cells(x + 1, 2)

            'on copie provinciale courte dans desc_reg_court_gacouest et desc_reg_court_sigmasante

            Union(.Cells(x + 1, [desc_reg_court_gacouest_pi].Column), _
            .Cells(x + 1, [desc_reg_court_sigmasante_pi].Column)) = Sheets("filtre_item").Cells(x + 1, 4)
           
          End With
           
'si le gac ayant régionale est ANO
         
        ElseIf Cells(x + 1, 12) = "ANO" Then

          With Sheets("produits_items")

            'Si ANO copie régionale longue dans desc_reg_gacouest

            .Cells(x + 1, [desc_reg_gacouest_pi].Column) = Sheets("filtre_item").Cells(x + 1, 6)

            'Si ANO copie régionale courte dans desc_reg_court_gacouest
                
            .Cells(x + 1, [desc_reg_court_gacouest_pi].Column) = Sheets("filtre_item").Cells(x + 1, 8)

            'Si ANO copie provinciale longue dans desc_reg_gaceq et desc_reg_sigmasante

            Union(.Cells(x + 1, [desc_reg_gaceq_pi].Column), _
            .Cells(x + 1, [desc_reg_sigmasante_pi].Column)) = Sheets("filtre_item").Cells(x + 1, 2)

            'Si ANO copie provinciale courte dans desc_reg_court_gaceq et desc_reg_court_sigmasante

            Union(.Cells(x + 1, [desc_reg_court_gaceq_pi].Column), _
            .Cells(x + 1, [desc_reg_court_sigmasante_pi].Column)) = Sheets("filtre_item").Cells(x + 1, 4)

          End With

'si le gac ayant régionale est SIGMA

         ElseIf Cells(x + 1, 12) = "SIGMA" Then

           With Sheets("produits_items")

            'Si SIGMA copie régionale longue dans desc_reg_sigmasante

            .Cells(x + 1, [desc_reg_sigmasante_pi].Column) = Sheets("filtre_item").Cells(x + 1, 6)

            'Si SIGMA copie régionale courte dans desc_reg_court_sigmasante

            .Cells(x + 1, [desc_reg_court_sigmasante_pi].Column) = Sheets("filtre_item").Cells(x + 1, 8)

            'Si SIGMA copie provinciale longue dans desc_reg_gaceq et desc_reg_gacouest

            Union(.Cells(x + 1, [desc_reg_gaceq_pi].Column), _
            .Cells(x + 1, [desc_reg_gacouest_pi].Column)) = Sheets("filtre_item").Cells(x + 1, 2)

            'Si SIGMA copie provinciale courte dans desc_reg_court_gaceq et desc_reg_court_gacouest

            Union(.Cells(x + 1, [desc_reg_court_gaceq_pi].Column), _
            .Cells(x + 1, [desc_reg_court_gacouest_pi].Column)) = Sheets("filtre_item").Cells(x + 1, 4)

          End With

'si le gac ayant régionale est AUCUN

         ElseIf Cells(x + 1, 12) = "AUCUN" Then
    
          With Sheets("produits_items")

            'Si "aucun" copie provinciale longue dans desc_reg_gaceq, desc_reg_gacouest et desc_reg_sigmasante

            Union(.Cells(x + 1, [desc_reg_gaceq_pi].Column), _
            .Cells(x + 1, [desc_reg_gacouest_pi].Column), _
            .Cells(x + 1, [desc_reg_sigmasante_pi].Column)) = Sheets("filtre_item").Cells(x + 1, 2)


            'Si "aucun" copie provinciale courte dans desc_reg_court_gaceq, desc_reg_court_gacouest et desc_reg_court_sigmasante

            Union(.Cells(x + 1, [desc_reg_court_gaceq_pi].Column), _
            .Cells(x + 1, [desc_reg_court_gacouest_pi].Column), _
            .Cells(x + 1, [desc_reg_court_sigmasante_pi].Column)) = Sheets("filtre_item").Cells(x + 1, 4)

          End With
              
'si le gac ayant régionale est TOUS
           
         ElseIf Cells(x + 1, 12) = "TOUS" Then
            
           With Sheets("produits_items")
            
            'Si TOUS copie régionale longue dans desc_reg_gacouest_pi, desc_reg_gaceq_pi, desc_reg_sigmasante_pi

            Union(.Cells(x + 1, [desc_reg_gacouest_pi].Column), _
            .Cells(x + 1, [desc_reg_gaceq_pi].Column), _
            .Cells(x + 1, [desc_reg_sigmasante_pi].Column)) = Sheets("filtre_item").Cells(x + 1, 6)

            'Si TOUS copie régionale courte dans desc_reg_court_gaceq_pi,desc_reg_court_gacouest_pi,desc_reg_court_sigmasante_pi

            Union(.Cells(x + 1, [desc_reg_court_gacouest_pi].Column), _
            .Cells(x + 1, [desc_reg_court_gaceq_pi].Column), _
            .Cells(x + 1, [desc_reg_court_sigmasante_pi].Column)) = Sheets("filtre_item").Cells(x + 1, 8)
        
          End With
        
         End If

    Next cell

'on detruit la feuille "filtre_item"
    Sheets("filtre_item").Delete

'on pointe sur la feuille produits_items
    Sheets("produits_items").Activate


'détruire les feuilles data et catalogue afin de libérer de l'Espace inutile

If sheetExists("data") Then Sheets("data").Delete
If sheetExists("catalogue") Then Sheets("catalogue").Delete
If sheetExists("FCG") Then Sheets("FCG").Delete
If sheetExists("mandat") Then Sheets("mandat").Delete

Application.ScreenUpdating = True
Application.DisplayAlerts = True

'sauvegarder le fichier

ActiveWorkbook.Save


End Sub

Je bloque toujours a ma recherche élaboré (le code a été mis en bleu, lignes 392 et 393) ... passé un par un les plages du filtre, essayé de faire le filtre élaboré directement dans excel et non par VBA mais j'ai toujours un erreur comme quoi que je ne peux seulement copier des données filtrées vers la feuille active.

Donc je ne sais pas si ce problème ce reflète dans VBA ... J,ai comparer entre mon fichier original et mes données ne sont pas plus filtrées donc je suis en pénurie d'idée ...

Si quelqu'un d'entre-vous pourriez m'aider a trouver la source d'erreur, ça serais vraiment apprécié !!!

Invité · 04/03/2020, 04h49

Envoyé par jpvba

Bonjour,

Pour votre information, voilà le code utilisé pour réaliser un filtre avancé selon le tuto de Philippe TULLIEZ (

) :

Code :

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

1
2
3
4
 
         Sheets("Dépenses").Range("Tableau1[#All]").AdvancedFilter Action:= _
         xlFilterCopy, CriteriaRange:=Range("'Quantités'!Criteria") _
        , CopyToRange:=Range("'Quantités'!Extract"), Unique:=False

Le filtre est mis au point manuellement et il est automatisé par ces 3 lignes. Pour certains filtres, la zone critère peut être également modifiée par VBA.

**halaster08** · 04/03/2020, 08h47

Je bloque toujours a ma recherche élaboré (le code a été mis en bleu, lignes 392 et 393) ... passé un par un les plages du filtre, essayé de faire le filtre élaboré directement dans excel et non par VBA mais j'ai toujours un erreur comme quoi que je ne peux seulement copier des données filtrées vers la feuille active.

Code :

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

1
2
    Sheets("filtre_item").Range("depart_filtre").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:= _
    .Range("filtre_elab"), CopyToRange:=Sheets("erreur de champs").Range("a1:q2"), Unique:=True

Bonjour,

L'erreur est assez explicite et il me semble mentionné dans le tuto, si tu souhaites envoyer le résultat du filtre sur une autre feuille que celle qui contient la base de données, les crtitères de filtre doivent se trouver sur la feuille où tu envoies les données, ce qui ne semble pas être le cas dans ton code.

**jpvba** · 04/03/2020, 16h59

L'erreur est assez explicite et il me semble mentionné dans le tuto, si tu souhaites envoyer le résultat du filtre sur une autre feuille que celle qui contient la base de données, les crtitères de filtre doivent se trouver sur la feuille où tu envoies les données, ce qui ne semble pas être le cas dans ton code.

Bonjour a vous,

Le tuto ne spécifie pas que ça dois etre absolument les critères sur la table d'exportation. Je les fais plusieurs fois dans le passé dont l'Exemple de mon 1er code qui fontionne. Monsieur Tulliez spécifie même dans la section VII-C de sont tutoriel EXportation vers une autre feuille que la table de données avec une astuce ... peut etre que c'est ça le hic de mon second code, je ne pointe pas au départ sur la feuille finale ...

Oui dans les exemples de sont tutoriels les critères et le copier dans sont sur la meme feuille ... possiblement pour faciliter les imprimes écrans et faciliter la compréhension. C'était ce même paradigme a l'époque de mon premier code, bien avant celle que j'ai mis en exemple qui fonctionne, que je ne voulais pas avoir les critères sur la meme feuille que les résultats et on m'a fais comprendre que c'était possible.

Voir également la section XI - En conclusion, nous retiendrons ... Aucune mention que les critères doivent etre sur la feuille "d'exportation"

à suivre

**Philippe Tulliez** · 04/03/2020, 17h24

Bonjour,
En utilisant la méthode AdvancedFilter, les données sources, la cellule ou la plage de cellules où les données doivent être exportées et la zone où se trouve les critères peuvent être dans des feuilles et même dans des classeurs différents (à condition qu'ils soient ouverts). La seule contrainte c'est de définir la parentalité complète de l'objet Range soit Classeur.Feuille.Plage

Par contre, sans avoir testé, cette ligne CopyToRange:=Sheets("erreur de champs").Range("a1:q2") est déjà une erreur. La zone d'exportation doit être une cellule vide ou une plage d'une seule ligne or ici dans A1:Q2, il y a deux lignes

**jpvba** · 04/03/2020, 17h40

Un gros merci monsieur Tulliez

Pourtant je croyais que le range destination dois avoir au moins une ligne i.e. les entêtes des champs voulu comme résultats et non une cellule vide. J'ai modifier le q2 par q1 et toujours pas de résultats ... pourtant cette même ligne fonctionne dans mon premier code

mise a jour 1

Je pointe maintenant sur le range "a1" et tous fonctionne avec les colonnes voulues

mise a jour 2

Seulement les bons titres de colonnes apparaît en pointant sur une seule et unique cellule contenant le titre ...

Si je pointe un peu plus bans dans la feuilles d'exportation, le filtre fonctionne mais les titre de colonnes voulues ne sont pas considérée, ce qui n'Est pas le résultats rechercher

je continue a expérimenté par essaie et erreur ...

**jpvba** · 04/03/2020, 21h02

JE viens de trouver mon problème ...

Dans ma plage d'exportation, je demande une colonne qui n'Est pas dans ma source de départ ...

Cela explique le pourquoi que mon filtre fonctionnais sur ma première sub et non dans son adaptation

Encore une fois les messages d'erreur de VBA n'est pas trop explicite.

Pour le range d'une ligne ou deux lignes, les 2 fonctionnent et me procure le même résultat

donc le dossier est clos

merci milles fois, les amis, pour votre précieuse aide

encore une fois monsieur Tulliez

erreur 1004 d'un filtre élaboré provenant d'un adaptation d'un code existant [XL-2013]

Macros et VBA Excel

Vue hybride

Discussions similaires

Partager

Partager