[XL-2007] Correction code VBA

Correction code VBA

Bonjour j ai ecrit un code il fonctionne mais à moitie j ai un onglet global qui fait 1500 ligne j ai un onglet que j extrais d un progamme qui me ramene des lignes mais cela est variable j ai prevu ca ma recherche se fait de l onglet global vers l autre pour savoir qu il recupere une valeur en particulier s il l a trouve il mets ok sinon rien dans l onglet global le probleme ca marche mais il s arrete a la 112 lignes dans global les 112 lignes sont l extraction que je fais je voudrais qu il aille jusqu a la derniere ligne de global qui peut m aider ci joint un bout du code!!!
Code:

1 2 3 4 5 6 7 8 9 sheets("GLOBAL").Select For i = 14 To 20 If Cells(1, i) = Fich Then Exit For Next Cells(2, i).Select ActiveCell.Formula = _ "=IF(ISNA(VLOOKUP(A2," & Fich & "!A:A,1,FALSE)),"""",""OK"")" Selection.AutoFill Destination:=Range(i & NN) Selection.AutoFill Destination:=Range(Cells(2, i), Cells(NN, i))

Bonjour,

Comment veux-tu qu'on t'aide ? Où est initialisé la valeur de "NN" ? Poste la totalité de ton code, et aussi un classeur exemple.

voila mon fichier initiale j integre un fichier que j extraint d une requete, je lance ma macro pour qu il me fasse une recherche de la feuille global a la feuille fev2012 que j ai importe le probleme et que dans la macro la recherche s arrete a la ligne 112 dans mon onglet global le chiffre 112 represente le nombre de lignes dans l onglet fev2012 moi ce que je veux c est qu il me balaie tout le fichier global et qui ne s arrete pas a 112ligne

Ton classeur ne comporte ni feuille fev2012 ni macro.

désole voici le fichier mais la macro est sur un autre fichier j ai essaye de l envoyer mais ca ne marche pas il n arrive pas à récuperer le fichier mais normalement ca fonctionne avec le bout de code que je vous ai envoye au debut le probleme viens de la

Bonjour,

Lorsque tu écris

Code:

Selection.AutoFill Destination:=Range(Cells(2, i), Cells(NN, i))

Tu demandes à effectuer une recopie incrémentée dans les cellules de la plage Range(Cells(2, i), Cells(NN, i)).
La dernière ligne de cette plage est déterminée par la variable NN.
Voilà pourquoi Daniel te demandait Où est initialisé la valeur de "NN" ?

Cordialement.

en faite je viens de corriger l erreur le bon code est celui ci mais j ai toujours le meme probleme c est que la recherche se fait bien mais il s arrete au bout de 112 lignes dans le fichier global voici le code
Code:

1 2 3 4 5 6 7 8 sheets("GLOBAL").Select For i = 14 To 20 If Cells(1, i) = Fich Then Exit For Next Cells(2, i).Select ActiveCell.Formula = _ "=IF(ISNA(VLOOKUP(A2," & Fich & "!A:A,1,FALSE)),"""",""OK"")" Selection.AutoFill Destination:=Range(Cells(2, i), Cells(NN, i))

Apparemment, le code est le même que celui que tu as posté la première fois. On ne sait toujours pas où tu initialises la valeur de NN. Qu'est-ce que tu as modifié. Poste la totalité de ton code et un classeur cohérent avec ce que tu expliques.

bon je vous envoie le fichier avec la macro qui va avec j espere que je pourrais l envoyer

je n arrive pas envoye le fichier au format macro je l ai mis en format xlsx et envoye la macro ci dessous merci à vous
Code:

1 2 3 4 5 6 7 8 9 10 11 sub macro4 sheets("GLOBAL").Select For i = 14 To 20 If Cells(1, i) = Fich Then Exit For Next Cells(2, i).Select ActiveCell.Formula = _ "=IF(ISNA(VLOOKUP(A2," & Fich & "!A:A,1,FALSE)),"""",""OK"")" Selection.AutoFill Destination:=Range(Cells(2, i), Cells(NN, i)) end sub

C'est bien où est-ce que tu entres une valeur dans la variable NN ?

oui c est ca mais est ce que tu peux modifier la macro pour qu elle me fasse un balayage complet du fichier globla!!:oops::oops::oops:

Je te pose une question. Peux-tu répondre s'il te plait ?

En admettant que NN soit le nombre de lignes, que représente "fich" ?

excuse moi de ne pas etre assez coherent:oops::oops::oops:

fich represente le fichier que j appel dans ma macro car je serais amener à recueperer plusieur fichier donc fich = au nom du fichier que j extrait exemple

fich=fev2012 fev2012 est le nom du fichier que j extrait et si j extrait jan2012

fich=jan2012.

Citation:

fich represente le fichier que j appel dans ma macro

Tu n'appelles aucun fichier dans ta macro. "fich" est une variable représentant une feuille. Débrouille-toi pour la renseigner, sinon, ça ne fonctionnera pas.
J'ai modifié en supposant que NN est le nombre de lignes de la feuille Global :
Code:

1 2 3 4 5 6 7 8 9 10 11 Sub macro4() Sheets("GLOBAL").Select For i = 14 To 20 If Cells(1, i) = Fich Then Exit For Next Cells(2, i).Select ActiveCell.Formula = _ "=IF(ISNA(VLOOKUP(A2," & Fich & "!A:A,1,FALSE)),"""",""OK"")" Selection.AutoFill Destination:=Range(Cells(2, i), Cells(NN, i)) End Sub

Comment envoyer un fichier macro?
Comme ça, tu verras tout le déroulement car ça ne fonctionne pas.

Le plus simple est de l'enregistrer au format "xls" et de le mettre en pièce jointe.
Sinon, tu fais comme tu as fait la première fois, tu mets simplement les macros dans le message et je les remets dans ton classeur.

ok bon premiere macro qui permet d ouvrir le fichier sous le fichier test2 il faut juste que tu change l adresse ou se trouve le fichier a rechercher fev2012 ne te preoccupe pas des bloqueurs si N/A je t ai mis en gras la ou ca bloque

Code:

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
Public Fich
Private Sub CommandButton1_Click()
 
sheets("Accueil").Select
' boucle de traitement
n = 3
 
Mypath = Feuil1.Cells(1, 2).Value
 
If Not Right(Mypath, 1) = "\" Then
        Mypath = Mypath & "\"   'sinon on rajoute '\' pour éviter les pbs
End If
 
 
Do While Range("I" & n).Value <> ""
    If UCase(Range("H" & n).Value) = "X" Then
 
    Workbooks.Open Filename:= _
        Mypath & Range("I" & n).Value & ".xlsx"
 
    Call CB_Ecrit_Import(Range("I" & n).Value)
 
    Workbooks(Range("I" & n).Value & ".xlsx").Close savechanges:=True
    End If
 
    n = n + 1
Loop
 
End Sub
 
Sub CB_Ecrit_Import(Fich)
 
' Appel Macro26
Call Macro26(Fich)
 
'#####################################################################################################
'Saisie des Ecritures Comptables dans Excel pour être insérée dans
'un fichier Texte importable dans ComptaBase
'Denis PRUNIER CEPAL 26 Février 2010 Version DP 1.01
'Denis PRUNIER CEPAL 04 Juin 2010 Version DP 1.03
'pour GCE Technologie
'#####################################################################################################
 
ActiveSheet.Unprotect
'ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
 
'-----------------------------------------------------------------------------------------------------
'Variable globales
'-----------------------------------------------------------------------------------------------------
'Titre des messages
Dim MonTitre As String
    MonTitre = "ComptaBase, fichier de lignes d'écritures comptables"
 
'Lignes début et fin
Range("B8").Select
Range("B8").Activate
 
Dim Li_Debut, Li_Fin As Long
    Li_Debut = 8
    Li_Fin = ActiveSheet.Cells(Li_Debut, 2).CurrentRegion.Rows.Count
 
'Colonnes début et fin
Dim Co_Debut, Co_Fin As Long
    Co_Debut = 1
    Co_Fin = 11
 
'Nombre d'erreur totale
Dim NbErr As Long
    NbErr = 0
 
'Nombre d'erreur sur la ligne traitée
Dim NbErrLi As Long
    NbErrLi = 0
 
'Nombre de lignes en erreur
Dim NbErrLiTte As Long
    NbErrLiTte = 0
 
'Nombre de Lignes Traitées
Dim NbLiTraitee As Long
    NbLiTraitee = 0
'-----------------------------------------------------------------------------------------------------
'Invite
'-----------------------------------------------------------------------------------------------------
If MsgBox("Etes_vous certains de bien vouloir créer le fichier de lignes d'écritures " & _
    "comptables à partir de " & Li_Debut & " ?", 292, MonTitre) = 7 Then
    'ActiveSheet.Unprotect
    'ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
    Exit Sub
End If
 
'-----------------------------------------------------------------------------------------------------
'Structure du fichier Excel sur 11 colonnes EXcel
'Identification des colonnes, cela permet de les changer d'ordre sans perturber la macro
'Li comme Ligne, Co comme Colonne et Nm comme Nom
'-----------------------------------------------------------------------------------------------------
'Entité GL (4c) = 2
    Dim Co_Entite As Integer
    Co_Entite = 2
    Dim Nm_Entite As String
'Compte (de 6c à 18c) = 3
    Dim Co_Cpte As Integer
    Co_Cpte = 3
    Dim Nm_Cpte As String
 'Débit = 4
    Dim Co_Deb As Integer
    Co_Deb = 4
    Dim Nm_Deb As Double
'Crédit = 5
    Dim Co_Cred As Integer
    Co_Cred = 5
    Dim Nm_Cred As Double
'Montant (crédit-débit)
    Dim Nm_Mnt As Double
'Libellé (30c) = 6
    Dim Co_Lib As Integer
    Co_Lib = 6
    Dim Nm_Lib As String
'Lettrage (60c) = 7
    Dim Co_Lettr As Integer
    Co_Lettr = 7
    Dim Nm_Lettr As String
'Partenaire (Conso) (Liste ICS) = 8
    Dim Co_Part As Integer
    Co_Part = 8
    Dim Nm_Part As String
'Export = 9
    Dim Co_Export As Integer
    Co_Export = 9
    Dim Nm_EXport As String
'Ligne traitée ? = 1 Li_Traitee (renseignées automatiquement par macro pour dire insertion fichier OK)
    Dim Co_Traitee As Integer
    Co_Traitee = 1
    Dim Nm_Traitee As String
'Date cpta (jj/mm/aaaa) = 12
    Dim Co_DateCpta As Integer
    Co_DateCpta = 12
    Dim Nm_DateCpta As String
'Ancien code devise 2 = EUR 100 = IFRS
    Dim Nm_Dev As String
'-----------------------------------------------------------------------------------------------------
'Nom du fichier
'-----------------------------------------------------------------------------------------------------
Dim MonFicCbase As String
If Range("GarderFichiersEcrit").Value = "Oui" Then
    MonFicCbase = ActiveWorkbook.Path & "\" & _
        Left(ActiveWorkbook.Name, InStr(1, ActiveWorkbook.Name, ".") - 1) & _
            "_" & ActiveSheet.Name & "_CBaseEcrit" & Format(Now(), "yyyy-mm-dd-hh-mm-ss") & ".txt"
Else
    MonFicCbase = ActiveWorkbook.Path & "\" & _
        Left(ActiveWorkbook.Name, InStr(1, ActiveWorkbook.Name, ".") - 1) & _
            "_" & ActiveSheet.Name & "_CBaseEcrit.txt"
End If
 
'-----------------------------------------------------------------------------------------------------
'Gestion du fichier, suppression du dernier et création du nouveau
'-----------------------------------------------------------------------------------------------------
On Error Resume Next 'au cas ou le fichier n'existe pas
If Range("GarderFichiersEcrit").Value = "Non" Then
    Kill MonFicCbase
End If
 
Close #1 'au cas ou il serait ouvert
'ouverture d'un nouveau fichier texte
Open MonFicCbase For Append As #1
'-----------------------------------------------------------------------------------------------------
'Démarrage lecture fichier et validation des données
'Seules les lignes sans erreur sont insérées dans un fichier
'-----------------------------------------------------------------------------------------------------
Dim TxEcrit As String 'Texte de la ligne à écrire dans le fichier
 
For l = Li_Debut To Li_Fin
    NbErrLi = 0 'nombre d'erreurs sur la ligne
    'Si la ligne a été déjà traitée on passe à la suivante.
    If ActiveSheet.Cells(l, Co_Traitee) <> "" Then GoTo LigneSuivante
 
    'Test de validité et incrémentation des variables
    'ActiveSheet.Cells(l, 1).Select
    GoSub ControlerErreurs
 
    'Si pas d'erreur sur la ligne on peut l'insérer dans le fichier
    If NbErrLi = 0 Then
        '---------------------------------------------------------------------
        'N° Entité
        TxEcrit = Nm_Entite
        'LOTGLECRIT_ID Null
        TxEcrit = TxEcrit & Chr(9)
        'LOTGLENTET_ID Null
        TxEcrit = TxEcrit & Chr(9)
        'LOTGLECRIT_ORIGINE  1 ponctuelle ou 0 modèle
        TxEcrit = TxEcrit & Chr(9) & "1"
        'LOTGLECRIT_COMPTE
        TxEcrit = TxEcrit & Chr(9) & Nm_Cpte
        'LOTGLECRIT_MT
        TxEcrit = TxEcrit & Chr(9) & Format(Nm_Mnt * 100, "0")
        'LOTGLECRIT_SENS
        'If ActiveSheet.Cells(l, Co_Cred) - ActiveSheet.Cells(l, Co_Deb) < 0 Then
            'TxEcrit = TxEcrit & Chr(9) & "0"
        'Else
            'TxEcrit = TxEcrit & Chr(9) & "1"
        'End If
        If ActiveSheet.Cells(l, Co_Deb) <> 0 And ActiveSheet.Cells(l, Co_Deb) <> "" Then
            TxEcrit = TxEcrit & Chr(9) & "0"
        Else
            TxEcrit = TxEcrit & Chr(9) & "1"
        End If
        'LOTGLECRIT_LIB
        TxEcrit = TxEcrit & Chr(9) & Nm_Lib
        'LOTGLECRIT_LETTRAGE
        TxEcrit = TxEcrit & Chr(9) & Nm_Lettr
        'LOTGLECRIT_PARTENAIRE
        TxEcrit = TxEcrit & Chr(9) & Nm_Part
        'LOTGLECRIT_LIB3 Null calculé automatiquement par CBase
        TxEcrit = TxEcrit & Chr(9)
        'LOTGLECRIT_CONTREPART n'est jamais alimenté en import
        TxEcrit = TxEcrit & Chr(9)
        'LOTGLECRIT_IMPORTE toujours = 1 = non exportable 2 = exportable
        TxEcrit = TxEcrit & Chr(9) & Nm_EXport
        'MODELECRIT_ID jamais renseigné dans le cas d'un import d'écritures
        Print #1, TxEcrit
        'Marquage traitée
        ActiveSheet.Cells(l, Co_Traitee) = Now()
        NbLiTraitee = NbLiTraitee + 1
        '---------------------------------------------------------------------
    End If
 
LigneSuivante:
Next
Close #1
 
'-----------------------------------------------------------------------------------------------------
'Procédure de contrôle des erreurs appelée par GoSub ControlerErreurs
'-----------------------------------------------------------------------------------------------------
GoTo ApresErreurs
ControlerErreurs:
'efface les éventuels commentaires précédents
For i = 1 To Co_Fin
    If i <> Co_Traitee Then
        ActiveSheet.Cells(l, i).ClearComments
    End If
Next
'!!!!!!!!!!!!Tests si n° entité
    If Len(ActiveSheet.Cells(l, Co_Entite)) <> 4 Then
        ActiveSheet.Cells(l, 2).Comment.Visible = False
        ActiveSheet.Cells(l, 2).Comment.Text Text:="Création fichier CBase" & Chr(10) _
            & "Attention entité invalide, la ligne n'est pas traitée !"
            NbErr = NbErr + 1
            NbErrLi = NbErrLi + 1
    End If
    'If Right(ActiveSheet.Cells(l, Co_Entite), 1) <> "E" And Right(ActiveSheet.Cells(l, Co_Entite), 1) <> "I" Then
        'ActiveSheet.Cells(l, 2).AddComment
        'ActiveSheet.Cells(l, 2).Comment.Visible = False
        'ActiveSheet.Cells(l, 2).Comment.Text Text:="Création fichier CBase" & Chr(10) _
            & "Attention entité invalide, le dernirer caractère doit être un E ou un I !"
            'NbErr = NbErr + 1
            'NbErrLi = NbErrLi + 1
    'End If
    Nm_Entite = CStr(ActiveSheet.Cells(l, Co_Entite).Value)
 
'!!!!!!!!!!!!Tests N° de Compte
    If Len(ActiveSheet.Cells(l, Co_Cpte)) < 6 Or Len(ActiveSheet.Cells(l, Co_Cpte)) > 18 Then
        ActiveSheet.Cells(l, Co_Cpte).AddComment
        ActiveSheet.Cells(l, Co_Cpte).Comment.Visible = False
        ActiveSheet.Cells(l, Co_Cpte).Comment.Text Text:="Création fichier CBase" & Chr(10) _
            & "Un compte comptable comporte au minimum 6 caractères et 18 au maximum !"
            NbErr = NbErr + 1
            NbErrLi = NbErrLi + 1
    End If
    If Not IsNumeric(Left(ActiveSheet.Cells(l, Co_Cpte), 1)) Then
        ActiveSheet.Cells(l, Co_Cpte).AddComment
        ActiveSheet.Cells(l, Co_Cpte).Comment.Visible = False
        ActiveSheet.Cells(l, Co_Cpte).Comment.Text Text:="Création fichier CBase" & Chr(10) _
            & "Un n° de compte commence toujours par un chiffre de 0 à 9"
            NbErr = NbErr + 1
            NbErrLi = NbErrLi + 1
    End If
    Nm_Cpte = CStr(ActiveSheet.Cells(l, Co_Cpte).Value)
 
'!!!!!!!!!!!!Tests Montant
    If ActiveSheet.Cells(l, Co_Cred) <> "" And ActiveSheet.Cells(l, Co_Deb) <> "" Then
        ActiveSheet.Cells(l, Co_Deb).AddComment
        ActiveSheet.Cells(l, Co_Deb).Comment.Visible = False
        ActiveSheet.Cells(l, Co_Deb).Comment.Text Text:="Création fichier CBase" & Chr(10) _
            & "On ne peut pas avoir un débit et un crédit sur une même ligne !"
        ActiveSheet.Cells(l, Co_Cred).AddComment
        ActiveSheet.Cells(l, Co_Cred).Comment.Visible = False
        ActiveSheet.Cells(l, Co_Cred).Comment.Text Text:="Création fichier CBase" & Chr(10) _
            & "On ne peut pas avoir un débit et un crédit sur une même ligne !"
            NbErr = NbErr + 1
            NbErrLi = NbErrLi + 1
    End If
    If ActiveSheet.Cells(l, Co_Cred) = "" And ActiveSheet.Cells(l, Co_Deb) = "" Then
        ActiveSheet.Cells(l, Co_Deb).AddComment
        ActiveSheet.Cells(l, Co_Deb).Comment.Visible = False
        ActiveSheet.Cells(l, Co_Deb).Comment.Text Text:="Création fichier CBase" & Chr(10) _
            & "Il faut obligatoirement un débit ou un crédit !"
        ActiveSheet.Cells(l, Co_Cred).AddComment
        ActiveSheet.Cells(l, Co_Cred).Comment.Visible = False
        ActiveSheet.Cells(l, Co_Cred).Comment.Text Text:="Création fichier CBase" & Chr(10) _
            & "Il faut obligatoirement un débit ou un crédit !"
            NbErr = NbErr + 1
            NbErrLi = NbErrLi + 1
    End If
    If Not IsNumeric(ActiveSheet.Cells(l, Co_Cred) - ActiveSheet.Cells(l, Co_Deb)) Then
        ActiveSheet.Cells(l, Co_Deb).AddComment
        ActiveSheet.Cells(l, Co_Deb).Comment.Visible = False
        ActiveSheet.Cells(l, Co_Deb).Comment.Text Text:="Création fichier CBase" & Chr(10) _
            & "Le montant n'est pas un nombre !"
            NbErr = NbErr + 1
            NbErrLi = NbErrLi + 1
    End If
    If IsNumeric(ActiveSheet.Cells(l, Co_Deb)) And ActiveSheet.Cells(l, Co_Cred) = "" Then
        Nm_Mnt = ActiveSheet.Cells(l, Co_Deb).Value
    End If
    If IsNumeric(ActiveSheet.Cells(l, Co_Cred)) And ActiveSheet.Cells(l, Co_Deb) = "" Then
        Nm_Mnt = ActiveSheet.Cells(l, Co_Cred).Value
    End If
 
'!!!!!!!!!!!!Tests Libellé
    If Len(ActiveSheet.Cells(l, Co_Lib)) < 1 Or Len(ActiveSheet.Cells(l, Co_Lib)) > 30 Then
        ActiveSheet.Cells(l, Co_Lib).AddComment
        ActiveSheet.Cells(l, Co_Lib).Comment.Visible = False
        ActiveSheet.Cells(l, Co_Lib).Comment.Text Text:="Création fichier CBase" & Chr(10) _
            & "Le libellé doit comporter de 1 à 30 caractères !"
            NbErr = NbErr + 1
            NbErrLi = NbErrLi + 1
    End If
    Nm_Lib = CStr(ActiveSheet.Cells(l, Co_Lib).Value)
 
'!!!!!!!!!!!!Tests Lettrage
    If Len(ActiveSheet.Cells(l, Co_Lettr)) > 12 Then
        ActiveSheet.Cells(l, Co_Lettr).AddComment
        ActiveSheet.Cells(l, Co_Lettr).Comment.Visible = False
        ActiveSheet.Cells(l, Co_Lettr).Comment.Text Text:="Création fichier CBase" & Chr(10) _
            & "Le lettrage doit comporter 12 caractères maximum !"
            NbErr = NbErr + 1
            NbErrLi = NbErrLi + 1
    End If
    Nm_Lettr = CStr(ActiveSheet.Cells(l, Co_Lettr).Value)
 
'!!!!!!!!!!!!Tests Partenaires
    If ActiveSheet.Cells(l, Co_Part) <> "" And Len(ActiveSheet.Cells(l, Co_Part)) < 6 Then
        ActiveSheet.Cells(l, Co_Part).AddComment
        ActiveSheet.Cells(l, Co_Part).Comment.Visible = False
        ActiveSheet.Cells(l, Co_Part).Comment.Text Text:="Création fichier CBase" & Chr(10) _
            & "Le code partenaire (Code de contrepartie Intragroupe Magnitude/ICS) comporte au minimum 6 caractères !"
            NbErr = NbErr + 1
            NbErrLi = NbErrLi + 1
    End If
    Nm_Part = CStr(ActiveSheet.Cells(l, Co_Part).Value)
 
'!!!!!!!!!!!!Tests Export
    If ActiveSheet.Cells(l, Co_Export) <> "" And UCase(ActiveSheet.Cells(l, Co_Export)) <> "OUI" _
        And ActiveSheet.Cells(l, Co_Export) <> "" And UCase(ActiveSheet.Cells(l, Co_Export)) <> "NON" Then
        ActiveSheet.Cells(l, Co_Export).AddComment
        ActiveSheet.Cells(l, Co_Export).Comment.Visible = False
        ActiveSheet.Cells(l, Co_Export).Comment.Text Text:="Création fichier CBase" & Chr(10) _
            & "La colonne Export accepte Oui, Non ou vide pour Oui"
            NbErr = NbErr + 1
            NbErrLi = NbErrLi + 1
    End If
 
    If ActiveSheet.Cells(l, Co_Export).Value = "" Then Nm_EXport = 2
    If UCase(ActiveSheet.Cells(l, Co_Export).Value) = "OUI" Then Nm_EXport = 2
    If UCase(ActiveSheet.Cells(l, Co_Export).Value) = "NON" Then Nm_EXport = 1
 
'Si au moins une erreur dans la ligne alors nombre de ligne en erreur + 1
 
If NbErrLi <> 0 Then NbErrLiTte = NbErrLiTte + 1
 
Return 'revient luste après instruction gosub ControlerErreurs
 
'-----------------------------------------------------------------------------------------------------
'Retour au programme après création fichier et contrôle des erreurs
'-----------------------------------------------------------------------------------------------------
ApresErreurs:
 
'-----------------------------------------------------------------------------------------------------
'Si des erreurs sont détectées, il faut demander si l'on garde le fichier
'car seule les lignes entièrement valide sont insérées
'-----------------------------------------------------------------------------------------------------
If NbErr <> 0 Then
    If MsgBox("Attention le fichier comporte " & NbErr & " erreur(s) sur " & _
        NbErrLiTte & " ligne(s) en erreur." & Chr(13) & Chr(13) & " -> Bien noter que si une cellule comporte " & _
        "plusieurs erreurs, elles sont toutes décomptées mais seule la dernière est commentée." & _
        Chr(13) & Chr(13) & "Voulez-vous conserver le fichier " & _
        "qui comporte uniquement les lignes sans erreur ?", 292, MonTitre) = 7 Then
        Kill MonFicCbase
    Else
        Range("DernierFichierEcrit").Value = MonFicCbase
    End If
Else
 
        Range("DernierFichierEcrit").Value = MonFicCbase
End If
 
'-----------------------------------------------------------------------------------------------------
'Fin
'-----------------------------------------------------------------------------------------------------
Dim MonTxMsg
    If NbErr = 0 Then MonTxMsg = " -> Le fichier Excel ne comporte aucune erreur !"
    If NbErr = 1 Then MonTxMsg = " -> Le fichier Excel comporte une erreur (cf commentaire) !"
    If NbErr = 2 Then MonTxMsg = " -> Le fichier EXcel comporte " & NbErr & " (cf commentaires) !"
'ActiveSheet.Unprotect
'ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
 
If NbLiTraitee = 0 Then
    MsgBox "Attention le fichier " & MonFicCbase & " ne comporte aucune ligne !", vbCritical, MonTitre
Else
    MsgBox "Création du fichier " & MonFicCbase & " terminée !" & Chr(13) & Chr(13) & _
        " -> Il comporte " & NbLiTraitee & " ligne(s) " & Chr(13) & MonTxMsg, _
        vbExclamation, MonTitre
End If
 
NbErr = 0
NbErrLi = 0
NbLiTraitee = 0
NbErrLiTte = 0
 
Windows("Test 2012").Close savechanges:=True
MsgBox "Traitement terminé", vbInformation
End Sub
 
Sub Macro26(Fich)
'
' Macro26 Macro
'
 
'
 
 
    Workbooks.Open Filename:="\\fsidfACT\Activites\IDF COMPTABILITE ETABLISSEMENT ACT\Gestion des factures\Pilotage factures\2012\CAP\REUNION OBRAUN\RELIQUAT CAP\CAP31122012.xlsm"
 
    sheets.Add
    For i = 1 To sheets.Count
        If sheets(1).Name = "Ecrit" & Fich Then Exit For
        If i = sheets.Count Then
            sheets("Ecrit").Select
            sheets("Ecrit").Copy After:=sheets(sheets.Count)
            sheets(sheets.Count).Select
            sheets(sheets.Count).Name = "Ecrit" & Fich
        End If
    Next
 
    sheets("Feuil1").Select
    Range("a1:Z99999").Value = ""
 
    Windows(Fich).Activate
    sheets("Factures avec statut").Select
    Rows("3:3").Select
    Selection.AutoFilter
    ActiveSheet.Range("$A$3:$AD$9000").AutoFilter Field:=6, Criteria1:="=CAP*" _
        , Operator:=xlAnd
    Columns("F:F").Select
'    Range("F5").Activate
    Selection.Copy
    sheets("Feuil1").Select
    Range("C1").Select
'    Selection.End(xlUp).Select
    ActiveSheet.Paste
    Rows("1:3").Select
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlUp
    Columns("C:C").Select
    Selection.TextToColumns Destination:=Range("C1"), DataType:=xlFixedWidth, _
        FieldInfo:=Array(Array(0, 1), Array(9, 9)), TrailingMinusNumbers:=True
    Columns("C:C").Select
    ActiveSheet.Range("$C$1:$C$65348").RemoveDuplicates Columns:=1, Header:= _
    xlNo
 
    Columns("C:C").Select
    Selection.Copy
    Windows("CAP31122012").Activate
    sheets("Feuil1").Select
    Range("A1").Activate
    ActiveSheet.Paste
 
    sheets("Feuil1").Name = Fich
 
 
   Call Macro3(Fich)
 
End Sub
 
 
 
Sub Macro3(Fich)
'
' Macro3 Macro
'
 
    Dim NN As Integer
    NN = Range("A65536").End(xlUp).Row
 
    Range("B1").Select
    ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-1],GLOBAL!R1:R1048576,4,0)"
    Selection.AutoFill Destination:=Range("B1:B" & NN)
    Range("B1:B" & NN).Select
    Range("C1").Select
    ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-2],GLOBAL!R1:R1048576,10,0)"
    Selection.AutoFill Destination:=Range("C1:C" & NN)
    Range("C1:C" & NN).Select
    Range("D1").Select
    ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-3],GLOBAL!R1:R1048576,2,0) & "" "" & RC[-3]"
    Range("D1").Select
    Selection.AutoFill Destination:=Range("D1:D" & NN)
 
 
    Columns("B:B").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
 
    Rows("1:1").Select
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    Columns("D:D").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("A1").Value = "CAPA"
    Range("C1").Value = "38835500"
    Range("F1").Value = "CHAGES A PAYER 2012"
    Range("B1").Value = "751E"
    Range("B1").Select
    Selection.AutoFill Destination:=Range("B1:B" & NN + 1)
    Range("D1").Select
    ActiveCell.Formula = "=SUM(E2:E" & NN & ")"
    ' test si #N/A
 
    If IsError(Range("D1").Value) Then
        MsgBox "Erreur sur ou plusieurs CAP, corriger et continuer", vbCritical
        Stop
    End If
 
    Range("D1").Select
    ActiveCell.Formula = "=SUM(E2:E" & NN & ")"
 
    sheets("GLOBAL").Select
    For i = 14 To 20
        If Cells(1, i) = Fich Then Exit For
    Next
    Cells(2, i).Select
    ActiveCell.Formula = _
        "=IF(ISNA(VLOOKUP(A2," & Fich & "!A:A,1,FALSE)),"""",""OK"")"
    Selection.AutoFill Destination:=Range(Cells(2, i), Cells(NN, i))
 
    Columns(i).Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
 
 
    sheets(Fich).Select
    Range("B1:F" & NN + 1).Select
    Selection.Copy
    sheets("Ecrit" & Fich).Select
    Range("B8").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
 
End Sub

Cette macro est à appliquer sur le fichier TEST 2.

Bon, je n'ai pas retrouvé "Macro4" dans ton message. Excuse-moi, mais je passe la main. J'espère que quelqu'un de plus malin que moi prendra le relais.

non la macro 4 c est moi qui te l est inscrit pour faire la recherche directe du fichier initiale la je t ai tout envoyé pour que tu es un aspect global