Bon Noël à tous
Tes données en Feuil1 à partir de A1 sans lignes vides
Restitution en feuil2
Option Explicit
Sub test()
Dim a, w(), x, y, i As Long, ii As Long, iii As Long, n As Long, t As Long
a = Sheets("Feuil1").Range("a1").CurrentRegion.Value
With CreateObject("Scripting.Dictionary")
For i = 2 To UBound(a, 1)
If Not .exists(a(i, 2)) Then
Set .Item(a(i, 2)) = _
CreateObject("Scripting.Dictionary")
.Item(a(i, 2)).CompareMode = 1
End If
If Not .Item(a(i, 2)).exists(a(i, 1)) Then
Set .Item(a(i, 2))(a(i, 1)) = _
CreateObject("Scripting.Dictionary")
End If
If Not .Item(a(i, 2))(a(i, 1)).exists(a(i, 5)) Then
ReDim w(1 To 3)
w(1) = a(i, 1): w(3) = a(i, 5)
Else
w = .Item(a(i, 2))(a(i, 1))(a(i, 5))
End If
w(2) = w(2) + a(i, 4)
.Item(a(i, 2))(a(i, 1))(a(i, 5)) = w
Next
x = .keys: y = .items
End With
Application.ScreenUpdating = False
'Restitution et mise en forme
With Sheets("Feuil2")
.Cells.Clear
For i = 0 To UBound(y)
n = n + 1 + t
t = 0
With .Cells(n, 1)
.Resize(, 4).Value = Array("Référence", "Client", "Quantité", "Prix")
For ii = 0 To y(i).Count - 1
For iii = 0 To y(i).items()(ii).Count - 1
t = t + 1
With .Offset(t)
If t = 1 Then .Value = x(i)
.Offset(, 1).Resize(, 3).Value = y(i).items()(ii).items()(iii)
End With
Next
Next
With .CurrentRegion
.Font.Name = "calibri"
.BorderAround Weight:=xlThin
.Borders(xlInsideVertical).Weight = xlThin
.VerticalAlignment = xlCenter
.Columns("a:b").HorizontalAlignment = xlCenter
.Columns("d").NumberFormat = "#,##0.00 $"
With .Rows(1)
.Font.Size = 11
.BorderAround Weight:=xlThin
.Interior.ColorIndex = 36
.HorizontalAlignment = xlCenter
End With
End With
End With
n = n + 1
Next
.Activate
End With
Application.ScreenUpdating = True
End Sub
klin89