Aide pour boucle

**zoumzoum59** · 26/02/2017, 22h18

Bonsoir a tous,

Je cherche un peu d'aide pour réaliser une boucle sur 2 colonnes de la feuille1, je dois tester si les cellules des colonnes F et G sont rempli ou pas jusque la pas de soucis, mais pour toutes les cellules des colonnes F est G de la ligne 1 comportant le code "PVC_F8925_2308" je dois multiplier la valeur compris dans A1 par B1, tout ça avec une boucle en VBA, pour le faire de lignes en lignes.
Ceci pour additionner toutes les valeurs correspondant au code "PVC_F8925_2308" dans la feuille2.
Et faire de meme pour les valeurs correspondant a "PVC_F8925_2320"

J'ai pensé a une boucle FOR EACH, mais je ne vois pas comment la mettre en forme.
Je joint le fichier correspondant aux explications.

En espérant que quelqu'un arrive a comprendre mon besoin, sinon n'hésité pas a me demander d'autres infos

Invité · 27/02/2017, 03h33

Envoyé par zoumzoum59

Bonjour,

Avant de coder en VBA, regardez si la fonction SommeProd peut vous donner directement le résultat :

Code :

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

=SOMMEPROD(((AireColonneF=A2)+(AireColonneG=A2))*(AireColonneA*AireColonneB))

Pièce jointe 248708

**zoumzoum59** · 27/02/2017, 06h32

Merci Eric KERGRESSE pour ton info avec SommeProd.

Mais je ne pense pas car je vais devoir le faire non pas sur uniquement la feuille1 mais plusieurs feuille consécutives et de nombre aléatoire avec le regroupement des sommes sur la dernière des feuilles.
Les codes "PVC_F8925_2308" sont également multiples et variant en nombre, j'en ai mis 2 en exemples mais il peut y en avoir 4,5,6... diffèrent
Et je ne pense pas que ce soit réalisable avec SommeProd, mais je peux me tromper
Le fichier que j'ai mis en piece jointe et un fichier réduit, pour simplifier ma demande et me donner le coup de pouce du depart

**unparia** · 27/02/2017, 08h09

Bonjour
Je n'ouvre jamais un classeur tiers. Je n'ai donc pas ouvert le tien et ne peux que tenter d'aider sur la seule base de l'image jointe à la réponse de Eric KERGRESSE, que je salue.
Un traitement en boucle (si tu veux traiter par VBA) est à faire de manière différente selon que les lignes sont ou non triées par rapport aux valeurs en colonnes F et G
Qu'en est-il de cet aspect ?

**zoumzoum59** · 27/02/2017, 13h01

Bonjour unparia,

Non les lignes ne peuvent pas être triées et se présentent comme indiquée dans l'image de Eric KERGRESSE.

C'est a dire que les codes en F et G peuvent être différents ( 6 différents maximum je pense) et présents de façon aléatoire ou ne pas être présent du tout.

En espérant avoir été clair

**zoumzoum59** · 28/02/2017, 21h08

Bonjour a tous,

De retour après un debut d'approche, je me suis dit que pour boucler sur les colonnes F et G, je devais déjà extraire les codes et avoir la liste des codes sans doublon.
J'ai donc utilisé le code suivantes qui m'affiche la liste dans une autre feuille en l'occurrence la Feuil2, mais je voudrais ne pas utiliser de Feuille mais intégrer les codes directement dans des variables, j'ai essayé d'utiliser une incrémentation de variable dans la boucle mais sans succès jusqu'ici.

Code :

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

1
2
3
4
5
6
7
8
Sub Extraction_Code()
    Set mondico = CreateObject("Scripting.Dictionary")
    For Each c In Range([F5], [F65000].End(xlUp))
        If Not mondico.Exists(c.Value) And c.Value <> "" Then mondico.Add c.Value, c.Value
    Next c
    Worksheets("Feuil2").Range("a2").Resize(mondico.Count, 1) = Application.Transpose(mondico.keys)
 
End Sub

Si quelqu'un a la solution, Merci d'avance.

Je verrai après pour boucler encore une fois sur toutes les lignes avec les codes extrait précédemment pour réaliser mon cumul de valeur.
Voici la direction que je prend en espérant que je fait le bon choix.

Invité · 01/03/2017, 02h50

Envoyé par zoumzoum59

Bonjour,

Essayez ce code qui reprend votre variable dico. Les éléments dans la variable sont ensuite triés et viennent alimenter une matrice qui cumule les produits des cellules 1 et 2 pour chaque référence.

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
 
Option Explicit
 
Sub Extraction_Code()
 
Dim MonDico As Object
Dim C As Range
Dim DerniereLigne As Long
Dim MaMatrice() As Variant
 
Dim ListeCle As Variant
Dim ListeElement As Variant
Dim I As Integer
Dim J As Integer
Dim Tempo1, Tempo2
 
    Set MonDico = CreateObject("Scripting.Dictionary")
 
    With Sheets("Feuil1")
         DerniereLigne = .Cells(.Rows.Count, 1).End(xlUp).Row  ' Colonne à adapter
         For Each C In .Range(.Cells(1, 6), .Cells(DerniereLigne, 7))
             If Not MonDico.Exists(C.Value) And C.Value <> "" Then MonDico.Add C.Value, C.Value
         Next C
 
         ListeCle = MonDico.Keys
         ListeElement = MonDico.Items
 
         ' Tri par ordre alphabétique dans la variable tableau
         '----------------------------------------------------
         For I = 0 To MonDico.Count - 2
             For J = I + 1 To MonDico.Count - 1
                 If ListeElement(I) > ListeElement(J) Then
 
                       Tempo1 = ListeCle(J)
                       Tempo2 = ListeElement(J)
 
                       ListeElement(J) = ListeElement(I)
                       ListeCle(J) = ListeCle(I)
 
                       ListeCle(I) = Tempo1
                       ListeElement(I) = Tempo2
 
                 End If
              Next J
         Next I
 
         ' Initialisation et remplissage de la matrice
         '--------------------------------------------
         ReDim MaMatrice(UBound(ListeCle), 1)
         For I = LBound(ListeCle, 1) To UBound(ListeCle, 1)
             MaMatrice(I, 0) = ListeCle(I)
         Next I
 
         ' Cumul des produits colonne 1 * colonne 2 pour chaque référence
         '---------------------------------------------------------------
         For I = LBound(MaMatrice, 1) To UBound(MaMatrice, 1)
             For Each C In .Range(.Cells(1, 6), .Cells(DerniereLigne, 6))
                 If C = MaMatrice(I, 0) Then MaMatrice(I, 1) = MaMatrice(I, 1) + (C.Offset(0, 1 - 6) * C.Offset(0, 2 - 6))
             Next C
             For Each C In .Range(.Cells(1, 7), .Cells(DerniereLigne, 7))
                 If C = MaMatrice(I, 0) Then MaMatrice(I, 1) = MaMatrice(I, 1) + (C.Offset(0, 1 - 7) * C.Offset(0, 2 - 7))
             Next C
         Next I
 
    End With
 
    ' Restitution
    '------------
    With Sheets("Feuil3")  ' A adapter
         .Range(.Cells(1, 1), .Cells(.Rows.Count, 2)).ClearContents
         For I = LBound(MaMatrice, 1) To UBound(MaMatrice, 1)
            .Cells(I + 1, 1) = MaMatrice(I, 0)
            .Cells(I + 1, 2) = MaMatrice(I, 1)
         Next I
    End With
 
    Set MonDico = Nothing
 
End Sub

**zoumzoum59** · 01/03/2017, 22h35

Merci Eric KERGRESSE

Ca fonctionne à merveille, mon niveau ne m'aurait jamais permis de créer un code pareil, j'ai meme du mal à tout comprendre.
Je l'ai un peu retravailler selon mes besoins et un fichier un peu different de celui présenté sur le forum.

Par contre, peux tu encore m'aider un peu, comment puis je boucler ce code sur plusieurs feuilles ?

Voici les modifications que j'ai apporté a ton code:

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
Sub Extraction_Code()
Dim MonDico As Object
Dim C As Range
Dim DerniereLigne As Long
Dim MaMatrice() As Variant
Dim ListeCle As Variant
Dim ListeElement As Variant
Dim I As Integer
Dim J As Integer
Dim Tempo1, Tempo2
    Set MonDico = CreateObject("Scripting.Dictionary")
    With Sheets("Feuil1")
         DerniereLigne = .Cells(.Rows.Count, 1).End(xlUp).Row  ' Colonne à adapter
         For Each C In .Range(.Cells(1, 7), .Cells(DerniereLigne, 10))
             If Not MonDico.Exists(C.Value) And C.Value <> "" Then MonDico.Add C.Value, C.Value
         Next C
 ListeCle = MonDico.Keys
         ListeElement = MonDico.Items
         ' Tri par ordre alphabétique dans la variable tableau
         '----------------------------------------------------
         For I = 0 To MonDico.Count - 2
             For J = I + 1 To MonDico.Count - 1
                 If ListeElement(I) > ListeElement(J) Then
                       Tempo1 = ListeCle(J)
                       Tempo2 = ListeElement(J)
                       ListeElement(J) = ListeElement(I)
                       ListeCle(J) = ListeCle(I)
                       ListeCle(I) = Tempo1
                       ListeElement(I) = Tempo2
                 End If
              Next J
         Next I
         ' Initialisation et remplissage de la matrice
         '--------------------------------------------
         ReDim MaMatrice(UBound(ListeCle), 1)
         For I = LBound(ListeCle, 1) To UBound(ListeCle, 1)
             MaMatrice(I, 0) = ListeCle(I)
         Next I
         ' Cumul des produits colonne 1 * colonne 2 pour chaque référence
         '---------------------------------------------------------------
         For I = LBound(MaMatrice, 1) To UBound(MaMatrice, 1)
             For Each C In .Range(.Cells(1, 7), .Cells(DerniereLigne, 7))
                 If C = MaMatrice(I, 0) Then MaMatrice(I, 1) = MaMatrice(I, 1) + (C.Offset(0, 1 - 7) * (C.Offset(0, 2 - 7) + 50))
             Next C
             For Each C In .Range(.Cells(1, 8), .Cells(DerniereLigne, 8))
                 If C = MaMatrice(I, 0) Then MaMatrice(I, 1) = MaMatrice(I, 1) + (C.Offset(0, 1 - 8) * (C.Offset(0, 2 - 8) + 50))
             Next C
             For Each C In .Range(.Cells(1, 9), .Cells(DerniereLigne, 9))
                 If C = MaMatrice(I, 0) Then MaMatrice(I, 1) = MaMatrice(I, 1) + (C.Offset(0, 1 - 9) * (C.Offset(0, 3 - 9) + 50))
             Next C
             For Each C In .Range(.Cells(1, 10), .Cells(DerniereLigne, 10))
                 If C = MaMatrice(I, 0) Then MaMatrice(I, 1) = MaMatrice(I, 1) + (C.Offset(0, 1 - 10) * (C.Offset(0, 3 - 10) + 50))
 
             Next C
         Next I
    End With
    ' Restitution
    '------------
    With Sheets("Feuil3")  ' A adapter
         .Range(.Cells(1, 1), .Cells(.Rows.Count, 2)).ClearContents
         For I = LBound(MaMatrice, 1) To UBound(MaMatrice, 1)
            .Cells(I + 1, 1) = MaMatrice(I, 0)
            .Cells(I + 1, 2) = MaMatrice(I, 1)
         Next I
    End With
    Set MonDico = Nothing
End Sub

Invité · 02/03/2017, 03h06

Envoyé par zoumzoum59

Bonjour,

Plusieurs méthodes sont possibles. Dans l'exemple traité, je suis resté sur mon code d'origine.

Dans ma solution, le principe est de :

Rendre paramétrique les procédures pour les appliquer à n'importe quel onglet.
Dissocier l'extraction de la restitution.

Remarques :

MaMatrice est l'objet qui réalise la restitution. Elle est présente dans deux procédures, il faut la déclarer au moins Private au niveau du module. Dans mon exemple, je l'ai déclarée Public.
Le tri du dico n'est plus nécessaire dans cette méthode. Il faudrait plutôt trier l'onglet cible à la fin du traitement.

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
 
Option Explicit
 
Public MaMatrice() As Variant
 
Sub ExtractionCodeSurPlusieursOnglets()
 
Dim ShCible As Worksheet
Dim ListeDesOngletsATraiter As Variant
Dim K As Integer
 
    Set ShCible = Sheets("Feuil3")
    With ShCible
         .Range(.Cells(1, 1), .Cells(.Rows.Count, 2)).ClearContents
    End With
    ListeDesOngletsATraiter = Array(Sheets("Feuil1"), Sheets("Feuil5"), Sheets("Feuil6"))
    For K = 0 To 2
        Extraction_Code ListeDesOngletsATraiter(K)
        RestituerLaMatrice ShCible 
    Next K
    ' Tri de l'onglet cible....
    Set ShCible = Nothing
 
End Sub
 
Sub Extraction_Code(ByVal FeuilleSource As Worksheet)
 
Dim MonDico As Object
Dim C As Range
Dim DerniereLigne As Long
 
Dim ListeCle As Variant
Dim ListeElement As Variant
Dim I As Integer
Dim J As Integer
Dim Tempo1, Tempo2
 
    Set MonDico = CreateObject("Scripting.Dictionary")
 
    With FeuilleSource
         DerniereLigne = .Cells(.Rows.Count, 1).End(xlUp).Row  ' Colonne à adapter
         For Each C In .Range(.Cells(1, 6), .Cells(DerniereLigne, 7))
             If Not MonDico.Exists(C.Value) And C.Value <> "" Then MonDico.Add C.Value, C.Value
         Next C
 
         ListeCle = MonDico.Keys
         ListeElement = MonDico.Items
 
         ' Tri par ordre alphabétique dans la variable tableau
         '----------------------------------------------------
         For I = 0 To MonDico.Count - 2
             For J = I + 1 To MonDico.Count - 1
                 If ListeElement(I) > ListeElement(J) Then
 
                       Tempo1 = ListeCle(J)
                       Tempo2 = ListeElement(J)
 
                       ListeElement(J) = ListeElement(I)
                       ListeCle(J) = ListeCle(I)
 
                       ListeCle(I) = Tempo1
                       ListeElement(I) = Tempo2
 
                 End If
              Next J
         Next I
 
         ' Initialisation et remplissage de la matrice
         '--------------------------------------------
 
         ReDim MaMatrice(UBound(ListeCle), 1)
         For I = LBound(ListeCle, 1) To UBound(ListeCle, 1)
             MaMatrice(I, 0) = ListeCle(I)
         Next I
 
         ' Cumul des produits colonne 1 * colonne 2 pour chaque référence
         '---------------------------------------------------------------
         For I = LBound(MaMatrice, 1) To UBound(MaMatrice, 1)
             For Each C In .Range(.Cells(1, 6), .Cells(DerniereLigne, 6))
                 If C = MaMatrice(I, 0) Then MaMatrice(I, 1) = MaMatrice(I, 1) + (C.Offset(0, 1 - 6) * C.Offset(0, 2 - 6))
             Next C
             For Each C In .Range(.Cells(1, 7), .Cells(DerniereLigne, 7))
                 If C = MaMatrice(I, 0) Then MaMatrice(I, 1) = MaMatrice(I, 1) + (C.Offset(0, 1 - 7) * C.Offset(0, 2 - 7))
             Next C
         Next I
 
    End With
 
    ' Restitution
    '------------
  '  With FeuilleCible ' A adapter
  '       .Range(.Cells(1, 1), .Cells(.Rows.Count, 2)).ClearContents
  '  End With
 
    Set MonDico = Nothing
 
End Sub
 
Sub RestituerLaMatrice(ByVal FeuilleCible As Worksheet)
 
Dim DerniereLigneCible As Long, MonItem As Long
Dim AireCible As Range, CelluleCible As Range
Dim ReferenceTrouvee As Boolean
 
    With FeuilleCible
 
         DerniereLigneCible = .Cells(.Rows.Count, 1).End(xlUp).Row
         Set AireCible = .Range(.Cells(1, 1), .Cells(DerniereLigneCible, 1))
 
         For MonItem = LBound(MaMatrice, 1) To UBound(MaMatrice, 1)
             ReferenceTrouvee = False
             For Each CelluleCible In AireCible
                 If CelluleCible = MaMatrice(MonItem, 0) Then
                    CelluleCible.Offset(0, 1) = CelluleCible.Offset(0, 1) + MaMatrice(MonItem, 1)
                    ReferenceTrouvee = True
                 End If
             Next CelluleCible
             If ReferenceTrouvee = False Then
                .Cells(DerniereLigneCible + 1, 1) = MaMatrice(MonItem, 0)
                .Cells(DerniereLigneCible + 1, 2) = MaMatrice(MonItem, 1)
                DerniereLigneCible = DerniereLigneCible + 1
             End If
         Next MonItem
 
         Set AireCible = Nothing
 
    End With
 
End Sub

**zoumzoum59** · 03/03/2017, 22h34

Un grand merci Eric

,

Je suis encore en phase de test mais ça a l'air de fonctionner nickel.
Je vais également essayer d'analyser les commentaires que tu m'as mis et essayer de déchiffrer au mieux ton code.

Et je vais l'adapter a mon besoin, mais le plus compliqué est fait et je t'en remercie encore une fois.

Je retravaille un peu ça et je mets mon code final si je ne rencontre pas une difficulté supplémentaire.

Aide pour boucle [XL-2002]

Macros et VBA Excel

Discussions similaires

Partager

Partager