Discussion :

[barbie-9]

Bonjour à tous,

j'ai le fichier suivant : référence, quantité et prix
j'aimerai bien créer une macro qui me permettra pour chaque référence qui se répète d'additionner la quantité et calculer le prix moyen pondéré par la quantité
Par exemple pour la référence 725105913 (colorée en jaune et qui se répète 3 fois) je veux avoir le résultat suivant: quantité= 0,7+1+0,055 et prix moyen pondéré =(0,7+1)*8,45 + (0,055*8,46) et éliminer après les lignes qui se répète

j'ai créé la macro suivante:

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
13
14
Dim Lg As Long
Dim p As Long
Dim Compteur As Integer
  Application.ScreenUpdating = False
  Lg = Range("A" & Rows.Count).End(xlUp).Row
  For p = Lg To 3 Step -1
    If Range("A" & p) = Range("A" & p - 1)  Then
      Compteur = Compteur + 1
      Range("B" & p - 1).Value = Range("B" & p) + Range("&" p - 1)
      Range("C" & p - 1).Value = Range("C" & p - 1) * Range("B" & p - 1)/ Range("B" & p - 1)
      Range("A" & p & ":C" & p).Delete shift:=xlShiftUp
    End If
  Next p
End Sub

Seulement le problème réside dans le calcul du prix pondéré par la quantité
y'a t-il quelqu'un qui peut m'aider à résoudre ce problème à fin d'obtenir le résultat souhaité. Merci d'avance

[mercatog]

Proposition utilisant des variables tableaux et un dictionnaire. il faudra activer la référence Micosoft Scripting Runtime

Les références peuvent être triées ou non.

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
Option Explicit
 
'/!\ Active la référence Microsoft Scripting Runtime
 
Sub Ponderation()
Dim Dico As New Scripting.Dictionary
Dim N As Long, i As Long
Dim Tb, Res
 
Application.ScreenUpdating = False
With Feuil1
    N = .Cells(.Rows.Count, 1).End(xlUp).Row
    Tb = .Range("A2").Resize(N - 1, 3)
End With
 
Set Dico = CreateObject("Scripting.Dictionary")
For i = 1 To N - 1
    If Not Dico.Exists(Tb(i, 1)) Then
        Dico.Add CStr(Tb(i, 1)), Tb(i, 2) & "|" & Tb(i, 3)
    Else
        Dico(Tb(i, 1)) = Tb(i, 2) & ";" & Dico(Tb(i, 1)) & ";" & Tb(i, 3)
    End If
Next i
 
N = Dico.Count
If N > 0 Then
    ReDim Res(1 To N + 1, 1 To 3)
    Res(1, 1) = "Réf": Res(1, 2) = "Q": Res(1, 3) = "Prix"
    For i = 0 To N - 1
        Res(i + 2, 1) = Dico.keys(i)
        Res(i + 2, 2) = SumAverage(Dico.items(i))
        Res(i + 2, 3) = SumAverage(Dico.items(i), True)    ' Round(SumAverage(Dico.items(i), True),2)
    Next i
    Set Dico = Nothing
    Feuil2.Range("A1").Resize(N + 1, 3) = Res
End If
End Sub
 
 
Private Function SumAverage(ByVal Tmp As String, Optional Avrg As Boolean) As Double
Dim TmpQ As String, TmpP As String
Dim N As Integer, i As Integer
Dim S As Double, Q As Double
Dim TblQ, TblP
 
TmpQ = Split(Tmp, "|")(0)
TmpP = Split(Tmp, "|")(1)
 
TblQ = Split(TmpQ, ";")
TblP = Split(TmpP, ";")
 
N = UBound(TblQ)
For i = 0 To N
    If Avrg Then
        S = S + TblP(i) * TblQ(i)
        Q = Q + TblQ(i)
    Else
        S = S + TblQ(i)
    End If
Next i
 
SumAverage = S / IIf(Avrg, Q, 1)
End Function

[barbie-9]

Merci Mercatog de m'avoir répondu seulement en activant la référence Micosoft Scripting Runtime et en copiant la macro pour avoir le résultat, la macro ne s'exécute pas

[mercatog]

Le code est testé sur ton fichier joint en #1 sauf si ton fichier réel diffère. Il faudra alors adapter le code (ligne 11, feuille source et ligne 35, feuille de destination)

Bien sûr les références sont en colonne A, les quantités en colonne B et les prix en colonne C.

[barbie-9]

slt mercatog, le code fonctionne mais j'ai remarqué que le prix moyen pondéré par la quantité (calculé) n'est pas correcte
prenons à titre d'exemple: Reference 725105913 quantité 1,755 prix 8,453988604 alors que le prix doit être 8.45031339
Cordialement

[Daniel.C]

Bonjour,

Si mercatog ne se manifeste pas, remets ton classeur en PJ parce que, apparemment, un modo a fait du zèle.

[barbie-9]

Bonjour,
Daniel.C voici le fichier

[mercatog]

Effectivement il y avait une petite coquille d'inattention.

Le code utilise un dictionnaire où on concatène successivement les quantités à gauche du | et les prix à droite.

LA fonction qui calcule la somme ou la moyenne doit multiplier Q(i)*P(N-i) et non Q(i)*P(i). Cf ligne 55 du code

Code corrigé

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
Option Explicit
 
'/!\ Active la référence Microsoft Scripting Runtime
Sub Ponderation()
Dim Dico As New Scripting.Dictionary
Dim N As Long, i As Long
Dim Ref As String
Dim Tb, Res
 
Application.ScreenUpdating = False
With Feuil1
    N = .Cells(.Rows.Count, 1).End(xlUp).Row
    Tb = .Range("A2").Resize(N - 1, 3)
End With
 
For i = 1 To N - 1
    Ref = CStr(Tb(i, 1))
    If Not Dico.Exists(Ref) Then
        Dico.Add Ref, Tb(i, 2) & "|" & Tb(i, 3)
    Else
        Dico(Ref) = Tb(i, 2) & ";" & Dico(Ref) & ";" & Tb(i, 3)
    End If
Next i
 
N = Dico.Count
If N > 0 Then
    ReDim Res(1 To N + 1, 1 To 3)
    Res(1, 1) = "Réf": Res(1, 2) = "Q": Res(1, 3) = "Prix"
    For i = 0 To N - 1
        Res(i + 2, 1) = Dico.keys(i)
        Res(i + 2, 2) = SumAverage(Dico.items(i))
        Res(i + 2, 3) = SumAverage(Dico.items(i), True)    ' Round(SumAverage(Dico.items(i), True),2)
    Next i
    Set Dico = Nothing
    Feuil2.Range("A1").Resize(N + 1, 3) = Res
End If
End Sub
 
 
Private Function SumAverage(ByVal Tmp As String, Optional Avrg As Boolean) As Double
Dim TmpQ As String, TmpP As String
Dim N As Integer, i As Integer
Dim S As Double, Q As Double
Dim TblQ, TblP
 
TmpQ = Split(Tmp, "|")(0)
TmpP = Split(Tmp, "|")(1)
 
TblQ = Split(TmpQ, ";")
TblP = Split(TmpP, ";")
 
N = UBound(TblQ)
For i = 0 To N
    If Avrg Then
        S = S + TblP(N - i) * TblQ(i)
        Q = Q + TblQ(i)
    Else
        S = S + TblQ(i)
    End If
Next i
 
SumAverage = S / IIf(Avrg, Q, 1)
End Function

[Daniel.C]

A priori, le problème vient du fait que certaines des cellules de la colonne A sont au format texte et d'autres au format numérique; notamment pour la référence 725105913.

[barbie-9]

mercatog ç bon sa fonctionne correctement, Merci

[nibledispo]

Bonjour,

Qu'as tu fais pour que ça marche ?
Perso, je retrouve toujours l'écart que tu as signalé il y a peu et ce mêmes après avoir passé toute la colonne A au format texte comme l'indiquait Daniel.

Cordialement.

[mercatog]

@Paul

Un dictionnaire est déterminé par des Clefs (Keys) et des items. Un Key X est unique et l'item Y correspondant peut être modifié.

Par analogie d'un dictionnaire normal: Les mots sont censés être uniques et leurs synonymes variables et pour chaque mot (key) tu as une correspondance avec des explications, définitions ou synonymes.

Explication du code:
Le code parcourt toutes les cellules en utilisant un dictionnaire. La ligne 17 transforme les données de la colonne 1 en String (Pour ne pas tenir compte du format des données que ce soient nombres ou textes)

Quand on a une nouvelle référence Ref dans la ligne i on l'ajoute comme clé (key) au dictionnaire et on ajoute Qi|Pi à l'item correspondant (Qi: Quantité et Pi: Prix de la ligne j)

Quand on a une référence Ref dans la ligne j et déjà ajoutée comme clé du dictionnaire, on modifie son item qui devient Qj;Qi|Pi;Pj (Qj: Nouvelle quantité et Pj: Nouveau prix)

La fonction SumAverage permet de calculer soit la somme soit la moyenne pondérée en subdivisant à l'aide de split un mot sous la forme Q3;Q2;Q1|P1;P2;P3 en valeurs souhaitées.

L'erreur d’inattention commise en ligne 55 et que je calculais la moyenne par (Q3*P1+Q2*P2+Q1*P3)/(Q1+Q2+Q3). L'ordre de concaténation à droite du signe | étant opposé à celui de gauche.

D'où la correction de la ligne 55

S = S + TblP(N - i) * TblQ(i) à la place de S = S + TblP(i) * TblQ(i)Une petite amélioration (optimisation) pour ne pas appeler la fonction 2 fois pour une seule 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
Option Explicit
 
'/!\ Active la référence Microsoft Scripting Runtime
Sub Ponderation()
Dim Dico As New Scripting.Dictionary
Dim N As Long, i As Long
Dim Ref As String
Dim T() As Double
Dim Tb, Res
 
Application.ScreenUpdating = False
With Feuil1
    N = .Cells(.Rows.Count, 1).End(xlUp).Row
    Tb = .Range("A2").Resize(N - 1, 3)
End With
 
For i = 1 To N - 1
    Ref = CStr(Tb(i, 1))
    If Not Dico.Exists(Ref) Then
        Dico.Add Ref, Tb(i, 2) & "|" & Tb(i, 3)
    Else
        Dico(Ref) = Tb(i, 2) & ";" & Dico(Ref) & ";" & Tb(i, 3)
    End If
Next i
 
N = Dico.Count
If N > 0 Then
    ReDim Res(1 To N + 1, 1 To 3)
    Res(1, 1) = "Réf": Res(1, 2) = "Q": Res(1, 3) = "Prix"
    For i = 0 To N - 1
        T = RECALCUL(Dico.items(i))
 
        Res(i + 2, 1) = Dico.keys(i)
        Res(i + 2, 2) = T(0)
        Res(i + 2, 3) = T(1)
    Next i
    Set Dico = Nothing
    Feuil2.Range("A1").Resize(N + 1, 3) = Res
End If
End Sub
 
 
Private Function RECALCUL(ByVal Tmp As String) As Double()
Dim TmpQ As String, TmpP As String
Dim N As Integer, i As Integer
Dim S As Double, Q As Double
Dim Tbl(0 To 1) As Double
Dim TblQ, TblP
 
TmpQ = Split(Tmp, "|")(0)
TmpP = Split(Tmp, "|")(1)
 
TblQ = Split(TmpQ, ";")
TblP = Split(TmpP, ";")
 
N = UBound(TblQ)
For i = 0 To N
    S = S + TblP(N - i) * TblQ(i)
    Q = Q + TblQ(i)
Next i
Tbl(0) = Q
Tbl(1) = S / Q
 
RECALCUL = Tbl
End Function

[nibledispo]

Bonjour Mercatog,

J'ai passé un certain temps à analyser le code et l'avait à peu près compris.

Afin d'être certain que :

Code :

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

 Dico(Tb(i, 1)) = Tb(i, 2) & ";" & Dico(Tb(i, 1)) & ";" & Tb(i, 3)

faisait bien ce que je pensais, j'avais introduit cette ligne:

Code :

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

Range("g" & i + 1) = Dico(Tb(i, 1))

J'avais bien remarqué l'inversion dans cette ligne mais n'est pas été assez futé pour voir son incidence sur la formule.

Ce qui m'a perturbé: c'est le 'true' correspondant à "Avrg"

Je comprenais bien qu'il était là pour ne pas calculer inutilement "Q" et aussi calculer "S" sur plusieurs éléments qui n'existent pas mais j'imagine mal comment VBA peut interpréter cela. Ce qui fait que j'aurais bien des difficultés à le manipuler à l'avenir.

la dernière version élimine de toute façon cette difficulté. et c'est très bien ainsi.

On pouvait, pour faire ressortir l'inutilité du calcul, poser S = TblQ(i) après le "else"

Je me demande comment Barbie a pu trouver un résultat correct sauf à avoir découvert l'erreur. Et si c'est le cas, la moindre des choses eut été d'informer les membres qui suivent la discussion, même s'ils ne se manifestent pas faute de connaissances.

Merci. Je progresse dans la manipulation des dictionnaires.

Cordialement.

[mercatog]

Je me demande comment Barbie a pu trouver un résultat correct sauf à avoir découvert l'erreur. Et si c'est le cas, la moindre des choses eut été d'informer les membres qui suivent la discussion, même s'ils ne se manifestent pas faute de connaissances.

Le code #8 rectifie le code #2 qui contenait l'erreur.

Le code #8 est correct et c'est lui qu'a finalement utilisé Barbie.


La variable optionnel Avrg lorsqu'elle est à True, ça veut dire qu'on obtient la moyenne pondérée des prix et si elle est omise (ou à false), ça veut dire qu'on obtient la somme des quantités.
De ce fait, on utilise une seule fonction SumAverage pour calculer soit la somme des quantités soit la moyenne pondérée des prix.

ça fonctionne bien mais en retour de chaque référence elle est appelée 2 fois et je suis conscient que ce n'est pas optimal.
D'où la dernière version où la fonction RECALCUL qui retourne un tableau à 2 éléments, le premier élément étant la somme des quantités et le second élément est la moyenne pondérée des prix et pour chaque référence, cette fonction est appelée une seule fois.

Une autre proposition utilisant 2 dictionnaires et une seule procédure et surtout sans gymnastique par rapport aux précédentes propositions

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
Option Explicit
 
'/!\ Active la référence Microsoft Scripting Runtime
Sub Ponderation()
Dim DicoQ As New Scripting.Dictionary
Dim DicoP As New Scripting.Dictionary
Dim N As Long, i As Long
Dim Ref As String
Dim T() As Double
Dim Tb, Res
 
Application.ScreenUpdating = False
With Feuil1
    N = .Cells(.Rows.Count, 1).End(xlUp).Row
    Tb = .Range("A2").Resize(N - 1, 3)
End With
 
For i = 1 To N - 1
    Ref = CStr(Tb(i, 1))
    If Not DicoQ.Exists(Ref) Then
        DicoQ.Add Ref, Tb(i, 2)
        DicoP.Add Ref, Tb(i, 2) * Tb(i, 3)
    Else
        DicoQ(Ref) = DicoQ(Ref) + Tb(i, 2)
        DicoP(Ref) = DicoP(Ref) + Tb(i, 2) * Tb(i, 3)
    End If
Next i
 
N = DicoQ.Count
If N > 0 Then
    ReDim Res(1 To N + 1, 1 To 3)
    Res(1, 1) = "Réf": Res(1, 2) = "Q": Res(1, 3) = "Prix"
 
    For i = 0 To N - 1
        Res(i + 2, 1) = DicoQ.Keys(i)
        Res(i + 2, 2) = DicoQ.Items(i)
        If Res(i + 2, 2) <> 0 Then Res(i + 2, 3) = DicoP.Items(i) / Res(i + 2, 2)
    Next i
    Set DicoQ = Nothing
    Set DicoP = Nothing
    Feuil2.Range("A1").Resize(N + 1, 3) = Res
End If
End Sub

[Daniel.C]

Bonjour,

Une autre approche, résultats en colonne F et G sur Feuil1 :

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
Sub Moyenne()
Dim C As Range, Plage As Range, Ligne As Long
Ligne = 1
Set Plage = Range([A2], Cells(Rows.Count, 1).End(xlUp))
For Each C In Plage
    If Not IsNumeric(Application.Match(C * 1, [F:F], 0)) Then
        Ligne = Ligne + 1
        Cells(Ligne, 6) = C.Value
        'If C.Row = 12 Then Stop
        Cells(Ligne, 7) = Evaluate("sumproduct((" & Plage.Address & "=""" & C.Value & """)*" & _
            Plage.Offset(, 1).Address & "*" & Plage.Offset(, 2).Address & ")") / _
            Evaluate("sumproduct(n(" & Plage.Address & "=""" & C.Value & """)*" & _
            Plage.Offset(, 1).Address & ")")
    End If
Next C
End Sub

[nibledispo]

Bonsoir Mercatog et Daniel,

Mercatog : La nouvelle approche avec deux dictionnaireS est effectivement plus simple.

Je m'aperçois que ma compréhension de "true" était totalement erronée et je préfère cela car je me voyais mal mettre en œuvre un jour une chose dont je ne saisis pas comment VBA parvient à l'interpréter.

Autant pour moi, le #8 m'avait échappé.

Daniel : c'est une approche intéressante avec match et sumproduct.

Par contre si match est lisible, sumproduct en revanche de par sa longueur est plus difficile d’accès.
Par ailleurs, si sur l'exemple la différence n'est pas perceptible, il me semble avoir lu quelque part que "sumproduct" péchait par sa lenteur sur une longue liste. Confirmes tu ce point ?

Je l'ai adapté pour avoir le résultat en feuil2 afin d'avoir un rendu identique quelque soit la méthode. (trois feuil2. à ajouter dans le code)

Cordialement.

[mercatog]

Enfin une autre proposition utilisant un seul dictionnaire

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
Option Explicit
 
'/!\ Active la référence Microsoft Scripting Runtime
Sub Ponderation()
Dim Dico As New Scripting.Dictionary
Dim N As Long, i As Long, j As Long, k As Long
Dim Ref As String
Dim Tb, Res()
 
Application.ScreenUpdating = False
With Feuil1
    N = .Cells(.Rows.Count, 1).End(xlUp).Row
    Tb = .Range("A2").Resize(N - 1, 3)
End With
 
ReDim Res(1 To 4, 1 To 1)
Res(1, 1) = "Réf": Res(2, 1) = "Q": Res(3, 1) = "Prix": j = 1
 
For i = 1 To N - 1
    Ref = CStr(Tb(i, 1))
    If Not Dico.Exists(Ref) Then
        j = j + 1
        Dico.Add Ref, j
        ReDim Preserve Res(1 To 4, 1 To j)
        Res(1, j) = Ref
        Res(2, j) = Tb(i, 2)
        Res(4, j) = Tb(i, 2) * Tb(i, 3)
        Res(3, j) = Tb(i, 3)
    Else
        k = Dico(Ref)
        Res(2, k) = Res(2, k) + Tb(i, 2)
        Res(4, k) = Res(4, k) + Tb(i, 2) * Tb(i, 3)
        If Res(2, k) <> 0 Then Res(3, k) = Res(4, k) / Res(2, k)
    End If
Next i
Set Dico = Nothing
 
Feuil2.Range("A1").Resize(j, 3) = Application.Transpose(Res)
End Sub

[Daniel.C]

Bonsoir à tous,

nibledispo :

sumproduct en revanche de par sa longueur est plus difficile d’accès.

Je te l'accorde, de ton point de vue. Pour moi, qui l'ai écrit sur la feuille Excel, je n'ai eu qu'à la retranscrire. Quant à la lenteur, c'est certain sur des milliers de formules. Dans ce cas, il n'y a qu'un calcul par ID. J'ai seulement publié cette solution parce que tu as dit, il me semble que la solution mercatog était incorrecte (et je n'ai pas vérifié). Et aussi pour montrer la diversité des approches.

[barbie-9]

Bonjour à tous
nibledispo désolée de ne pas te répondre.
Bon je ne suis une experte dans la programmation mais j'ai juste testé le code de mercatog sur mon fichier et j'ai remarqué que le résultat obtenu est correcte. Je remarque que la discussion est intéressante. Merci à tous

[nibledispo]

Re... à tous,

Mercatog: ok pour la dernière solution qu'il me faut encore assimiler.

Daniel : j'ai bien compris qu'il s'agissait de montrer les diverses possibilités.
par curiosité j'ai recopier N fois les données pour arriver à près de 6000 lignes.
et introduit un timer dans la dernière version Mercatog et la tienne.
Mercatog : 00:22:30 secondes
Daniel : 07:30:00 secondes

Je ne sais comment il faut interpréter le résultat et quel crédit lui accorder car il ne s'est pas écoulé 7 secondes mai toute au plus 1. la différence ressentie est négligeable.

En tout cas cet essai m'a permis de vérifier que le résultat restait bon sur une liste non triée.

Barbie : pas de problème, c'est moi qui ai fait l'impasse sur un post.

Cordialement