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