Supprimer doublon avec total

[Ocus Pocus]

Bonjour à tous,
J'ai un fichier dans lequel avec des codes produits(A), quantité (B) et prix (C).
Certains codes apparaissent plusieurs fois et je souhaiterai faire un total en colonne D et supprimer les doublons.
En pièce jointe une partie du fichier qui comporte un peu moins de 3000 lignes...
Merci d'avance, bonne journée.

[dubois]

Bonjour,

à tester

Code: Tout sélectionner

Sub Compile()
Dim Lg&, i&, x&
    Application.ScreenUpdating = False
    Lg = Range("a" & Rows.Count).End(xlUp).Row
   
    '--- tri colonne A ---
   Range("a2:d" & Lg).Sort _
        Key1:=Range("a2"), Order1:=xlAscending, _
    Header:=xlNo, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
   
    '--- compile si besoin ---
   For i = 2 To Lg
        If Cells(i + 1, "a") = Cells(i, "a") Then
            x = i
            Do While Cells(x + 1, "a") = Cells(i, "a")
               Cells(i, "b") = Cells(i, "b") + Cells(x + 1, "b")
               Cells(x + 1, "c").ClearContents
               x = x + 1
            Loop
            i = x
        End If
    Next i
        On Error Resume Next
    Range("c2:c" & Lg).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub

Amicalement
Claude

[Ocus Pocus]

Merci infiniment Claude, c'est plus que parfait !
Outre le fait que cela solutionne mon problème, je viens de faire mes premiers pas dans MVB en collant les lignes de commande dans cet univers stratosphérique !
Il ne me reste plus qu'à essayer de trouver où l'on coche le fait que le sujet soit résolu...
Bonne journée.
Amicalement.

[dubois]

pour solder le poste, dans ton message

A_Résolu3.JPG (14.61 Kio) Vu 61 fois

[ceuzin]

Bonjour,

-Méthode rapide
-Ne modifie pas l'ordre initial

Code: Tout sélectionner


Sub DoublonsTotal()
  Set d = CreateObject("Scripting.Dictionary")
  Set d2 = CreateObject("Scripting.Dictionary")
  For Each c In Range("a2", [a65000].End(xlUp))
    d(c.Value) = d(c.Value) + c.Offset(, 1).Value
    d2(c.Value) = c.Offset(, 2)
  Next c
  [A2:C1000].ClearContents
  [a2].Resize(d.Count, 1) = Application.Transpose(d.keys)
  [b2].Resize(d.Count, 1) = Application.Transpose(d.items)
  [c2].Resize(d.Count, 1) = Application.Transpose(d2.items)
End Sub
 

Ceuzin

[Ocus Pocus]

Bonjour Ceuzin,
merci également pour cette méthode qui ne change pas l'ordre initial et qui m'a déjà servi ce matin pour un autre fichier.
Ah si seulement le forum des utilisateurs Sage était aussi dynamique, réactif et efficace que celui-ci...
Bonne journée.