Re Hosni,
Ai je bien compris
Je n'ai pas testé.
Option Explicit
Sub test()
Dim a, w(), i As Long, j As Long, n As Long, e, v, x, y
With Sheets("Nourrisson").Range("a1").CurrentRegion
a = .Value
With CreateObject("Scripting.Dictionary")
.CompareMode = 1
For i = 2 To UBound(a, 1)
If Not .exists(a(i, 3)) Then
Set .Item(a(i, 3)) = CreateObject("Scripting.Dictionary")
.Item(a(i, 3)).CompareMode = 1
End If
If Not .Item(a(i, 3)).exists(a(i, 1)) Then
ReDim w(1 To 3, 1 To 2)
Else
w = .Item(a(i, 3))(a(i, 1))
ReDim Preserve w(1 To 3, 1 To UBound(w, 2) + 1)
End If
w(1, UBound(w, 2) - 1) = a(i, 3)
w(2, UBound(w, 2) - 1) = a(i, 2)
w(3, UBound(w, 2) - 1) = a(i, 1)
.Item(a(i, 3))(a(i, 1)) = w
Next
For Each e In .keys
For Each v In .Item(e).keys
w = .Item(e)(v)
w(1, UBound(w, 2)) = "Total " & e & " " & v
w(2, UBound(w, 2)) = Application.Sum(Application.Index(w, 2, Evaluate("row(1:" & UBound(w, 2) - 1 & ")")))
.Item(e)(v) = w
Next
Next
x = .keys: y = .items
End With
Application.ScreenUpdating = False
With .Offset(, .Columns.Count + 1).Resize(1, 3)
.CurrentRegion.Clear
.Value = Array("Clients", "Quantité", "Numéro Lot")
n = 2
For i = 0 To UBound(x)
For j = 0 To y(i).Count - 1
'w = y(i).items()(j)
'.Cells(n).Resize(UBound(w, 2), 3).Value = Application.Transpose(Application.Index(w, 0, 0))
With .Cells(n, 1).Resize(UBound(y(i).items()(j), 2), 3)
.Value = Application.Transpose(Application.Index(y(i).items()(j), 0, 0))
.BorderAround Weight:=xlThin
End With
With .Cells(n + UBound(y(i).items()(j), 2) - 1, 1).Resize(, 2)
.Interior.ColorIndex = 40
.BorderAround Weight:=xlThin
End With
n = n + UBound(y(i).items()(j), 2)
Next
Next
With .CurrentRegion
.Font.Name = "calibri"
.Font.Size = 10
.VerticalAlignment = xlCenter
.BorderAround Weight:=xlThin
.Borders(xlInsideVertical).Weight = xlThin
With .Rows(1)
.Font.Size = 11
.Interior.ColorIndex = 19
.BorderAround Weight:=xlThin
.HorizontalAlignment = xlCenter
End With
.Columns.AutoFit
End With
End With
.Parent.Activate
Application.ScreenUpdating = True
End With
End Sub
klin89