Salut le forum

J'ai un soucis avec le code ci-dessous.
En effet, il est sensé m'aider à faire la synthèse de plusieurs feuilles.
Je définis des critères de lignes à copier et lorsque la condition est vérifiée, la copier se réalise vers la feuille "SOURCE".
Je constate que la copie ne prend pas en compte tous les éléments notemment cette ligne:
Code : Sélectionner tout - Visualiser dans une fenêtre à part
Val_possibles(12) = "253900"
La ligne portant cette rubrique devait aussi être copié vers la feuille "SOURCE" mais la copie ne se fait pas.
Voici l'intégralité du code à apprécier:
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
Sub Execution(repertoire_source As String, ByVal Cible As Worksheet)
 
Dim i As Long
Dim Max_ligne As Long
Dim last_source_line As Long
 
Dim B, Str As String
Dim Val_possibles(13) As Variant
Dim Match As Boolean
Dim Lignes_a_suppr As Collection
Dim L As Variant
 
Dim source As Worksheet
 
'Import du fichier
Call Copie(Cible, repertoire_source)
'Split en colonnes
Call Split(Cible)
 
Set source = Sheets("Source")
'Suppression des colonnes B,E,F,I,J,K
Cible.Columns("k:k").Delete Shift:=xlToLeft
Cible.Columns("j:j").Delete Shift:=xlToLeft
Cible.Columns("i:i").Delete Shift:=xlToLeft
Cible.Columns("f:f").Delete Shift:=xlToLeft
Cible.Columns("e:e").Delete Shift:=xlToLeft
Cible.Columns("b:b").Delete Shift:=xlToLeft
 
'Suppression des lignes pour lesquelles la cellule B est de longueur inférieure à 6
'Les lignes sont d'abord stockées dans une collection, afin de ne pas perturber la boucle
'Puis tous les membres de la collection sont supprimés
Max_ligne = Cible.UsedRange.Rows.Count
Set Lignes_a_suppr = New Collection
 
For i = 1 To Max_ligne
    Str = Cible.Cells(i, 2).Value
    Str = Replace(Str, " ", "")
 
    If Len(Str) < 6 Or Str = "------" Then 'la condition 6 tirets n'est pas dans le cahier des charges mais elle m'a paru évidente
        Lignes_a_suppr.Add Cible.Cells(i, 2).EntireRow
    End If
Next i
For Each L In Lignes_a_suppr
    L.Delete
Next L
 
Set Lignes_a_suppr = Nothing
 
'Insertion d'une ligne
Cible.Rows("1:1").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
 
'Titres des colonnes
Cible.Cells(1, 1).Formula = "Code Agence"
Cible.Cells(1, 2).Formula = "RC"
Cible.Cells(1, 3).Formula = "Libellé"
Cible.Cells(1, 4).Formula = "Montant"
Cible.Cells(1, 5).Formula = "Nbre"
 
'Inscription du nom de la feuille en colonne A si b non vide, ou b rempli de blancs
For i = 2 To Max_ligne
    If Replace(Cible.Cells(i, 2).Value, " ", "") <> "" Then
        Cible.Cells(i, 1).Value = Cible.Name
    End If
Next i
 
 
'Suppression des .00 et des virgules
 
Cible.Range("D:E").Replace What:=".00", Replacement:="", LookAt:=xlPart, _
    SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
    ReplaceFormat:=False
 
Cible.Range("D:E").Replace What:=",", Replacement:="", LookAt:=xlPart, _
    SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
    ReplaceFormat:=False
 
 
'Copie des lignes correspondant à certains critères
 
last_source_line = source.Range("A65000").End(xlUp).Row
 
'Pour rajouter des valeurs à ressortir dans l'onglet source, ne pas oublier de redimensionner
'la taille du tableau dans les déclarations
Val_possibles(0) = "251125"
Val_possibles(1) = "251132"
Val_possibles(2) = "251134"
Val_possibles(3) = "251173"
Val_possibles(4) = "253110"
Val_possibles(5) = "253111"
Val_possibles(6) = "253115"
Val_possibles(7) = "253116"
Val_possibles(8) = "253118"
Val_possibles(9) = "253210"
Val_possibles(10) = "253216"
Val_possibles(11) = "253310"
Val_possibles(12) = "253900"
 
'Copie des lignes comprenant les valeurs énoncées dans le tableau Val_possibles
For i = 1 To Max_ligne
    Match = False
    For Each v In Val_possibles
        If v = Cible.Cells(i, 2).Value Then
            Match = True
            Exit For
        End If
    Next v
    If Match Then
        Cible.Cells(i, 2).EntireRow.Copy
        DoEvents
        source.Select
        source.Rows(last_source_line & ":" & last_source_line).Select
        source.Paste
        last_source_line = last_source_line + 1
    End If
Next i
 
End Sub
je reste à votre disposition pour des compléments d'informations