Fusionner A ET Additionner C si doublon B

[Ben_Co]

Bonjour à tous,

J'ouvre un sujet car je n'ai pas trouvé mon bonheur sur les autres postes du forum.

Je souhaite fusionner une cellule A ET additionner une cellule C si la cellule B est en doublon, tout ça sous VBA.

Comment pourrais-je m'y prendre?
Je vous joint un exemple pour plus de compréhension.


Je vous remercie d'avance.


Cordialement,

 

[jpb388]

Re : Fusionner A ET Additionner C si doublon B

Bonjour a tous
regarde si cela te va

 

[Ben_Co]

Re : Fusionner A ET Additionner C si doublon B

Bonjour à toi et merci de ta réponse.

Désolé de la voir si tard. Je regarde ça ce soir et je reviens vers toi *

Encore merci !


Cordialement,

 

[Ben_Co]

Re : Fusionner A ET Additionner C si doublon B

Re,

Alors je viens de regarde ta macro elle est vraiment pas mal!
Pourrais tu m'expliquer cette partie du code ? Je ne comprends pas vraiment que fait exactement chaque ligne.

For Each Ctl In Sh.Range("B5:B" & Lg)
If Code.Exists(Ctl.Text) = True Then
Num.Item(Ctl.Text) = Num.Item(Ctl.Text) & " " & Ctl.Offset(0, -1)
Code.Item(Ctl.Text) = Ctl.Offset(0, 1)
Qte.Item(Ctl.Text) = CDbl(Qte.Item(Ctl.Text)) + CDbl(Ctl.Offset(0, 2))
Tableau = Split(Ref.Item(Ctl.Text), " ")
For i = 0 To UBound(Tableau)
If Ctl.Offset(0, 3) = Tableau(i) Then
Trouvé = True
Exit For
End If
Next i
If Trouvé = False Then Ref.Item(Ctl.Text) = Ref.Item(Ctl.Text) & " " & Ctl.Offset(0, 3)
Trouvé = False
Else
Num.Add Ctl.Text, Ctl.Offset(0, -1)
Code.Add Ctl.Text, Ctl.Offset(0, 1)
Qte.Add Ctl.Text, Ctl.Offset(0, 2)
Ref.Add Ctl.Text, Ctl.Offset(0, 3)
End If

Merci pour ton aide précieuse !

Cordialement,

 

[jpb388]

Re : Fusionner A ET Additionner C si doublon B

Bonsoir a tous

Option Explicit

'nécessite Microsoft Scripting Runtime
 Sub test()
 Dim Code As Dictionary, Num As Dictionary, Qte As Dictionary, Ref As Dictionary
 Dim Lg&, Ctl As Range, Sh As Worksheet, Tableau$(), i%, Trouvé As Boolean
 Set Sh = Sheets("Feuil1")
 Set Code = CreateObject("Scripting.dictionary")
 Set Num = CreateObject("Scripting.dictionary")
 Set Qte = CreateObject("Scripting.dictionary")
 Set Ref = CreateObject("Scripting.dictionary")
 Range("G13:K200").ClearContents ]'efface la plage
 Lg = Sh.Range("A" & Rows.Count).End(xlUp).Row 'dernière ligne
 For Each Ctl In Sh.Range("B5:B" & Lg) 'teste si l'entrée est existante
     If Code.Exists(Ctl.Text) = True Then 'oui elle l'est la colonne b etant unique _
     je m'en sert comme référence
        Num.Item(Ctl.Text) = Num.Item(Ctl.Text) & " " & Ctl.Offset(0, -1) ]'les numéro fesant parti _
        du même code
        Code.Item(Ctl.Text) = Ctl.Offset(0, 1) ici la designation 1 seule /code
        Qte.Item(Ctl.Text) = CDbl(Qte.Item(Ctl.Text)) + CDbl(Ctl.Offset(0, 2))' _
        on additionne la quantité de caque code similair
        Tableau = Split(Ref.Item(Ctl.Text), " ")' traitement ref ref/code dabs un tableau
        For i = 0 To UBound(Tableau)
           If Ctl.Offset(0, 3) = Tableau(i) Then
            Trouvé = True'si un des element de tableau=ctl
            Exit For
           End If
        Next i
        [COLOR="#00FF00"]'si trouvé on ecrase l'dentique sinon on l'ajoute
        If Trouvé = False Then Ref.Item(Ctl.Text) = Ref.Item(Ctl.Text) & " " & Ctl.Offset(0, 3)
        Trouvé = False'on remet a false pour faire la comparaison suivante
     Else  'non elle ne l'est pas alors on ajoute les nouvelles données aux dictionnarys (tableau a 1 dimension)
        Num.Add Ctl.Text, Ctl.Offset(0, -1)
        Code.Add Ctl.Text, Ctl.Offset(0, 1)
        Qte.Add Ctl.Text, Ctl.Offset(0, 2)
        Ref.Add Ctl.Text, Ctl.Offset(0, 3)
     End If
 Next Ctl'inscription sur la feuille des dictionnary
 [G13].Resize(Num.Count) = Application.Transpose(Num.Items)
 [H13].Resize(Code.Count) = Application.Transpose(Code.Keys)
 [I13].Resize(Code.Count) = Application.Transpose(Code.Items)
 [J13].Resize(Qte.Count) = Application.Transpose(Qte.Items)
 [K13].Resize(Ref.Count) = Application.Transpose(Ref.Items)
 End Sub

 

[Ben_Co]

Re : Fusionner A ET Additionner C si doublon B

Et peut-on réécrire par dessus le tableau de référence? Car là ça crée un nouveau tableau mais moi je souhaiterai que le résultat s'affiche dans le même tableau.

Cordialement,

 

[jpb388]

Re : Fusionner A ET Additionner C si doublon B

re
voila le fichier

 

[Ben_Co]

Re : Fusionner A ET Additionner C si doublon B

Re,

Merci de ton aide !
Cependant, juste un petit détail : quand on clique plusieurs fois sur le bouton, ça "bug" !

Y'a un moyen pour l'empêcher de se lancer si il trouve pas de doublon?

En tout cas, chapeau pour la macro, elle est vraiment bien foutue !


Cordialement,

 

[jpb388]

Re : Fusionner A ET Additionner C si doublon B

re normalement c'est bon