Option Explicit
Sub test()
Dim a, w(), i As Long, j As Long, n As Long, dico As Object
Set dico = CreateObject("Scripting.Dictionary")
dico.CompareMode = 1
With Sheets("Base de données")
a = .Range("b3").CurrentRegion.Value
For i = 2 To UBound(a, 1)
If Not dico.exists(a(i, 2)) Then
Set dico(a(i, 2)) = _
CreateObject("Scripting.Dictionary")
End If
If Not dico(a(i, 2)).exists(a(i, 3)) Then
dico(a(i, 2))(a(i, 3)) = VBA.Array(a(i, 2), a(i, 3), Empty)
End If
w = dico(a(i, 2))(a(i, 3))
w(2) = w(2) + a(i, 4)
dico(a(i, 2))(a(i, 3)) = w
Next
End With
Application.ScreenUpdating = False
With Sheets("synthèse1").Range("b2")
.CurrentRegion.Offset(1).Clear
n = 1
For i = 0 To dico.Count - 1
For j = 0 To dico.items()(i).Count - 1
With .Offset(n).Resize(1, UBound(dico.items()(i).items()(j), 1) + 1)
.Value = dico.items()(i).items()(j)
End With
n = n + 1
Next
Next
With .CurrentRegion
.Font.Name = "calibri"
.Font.Size = 10
.VerticalAlignment = xlCenter
.BorderAround Weight:=xlThin
.Borders(xlInsideVertical).Weight = xlThin
.Columns.AutoFit
End With
End With
Set dico = Nothing
Application.ScreenUpdating = True
End Sub