Sub Regroupe()
Dim dest As Range, tablo, d1 As Object, d2 As Object, i&, x$
Set dest = [G3] '1ère cellule des résultats, à adapter
Application.ScreenUpdating = False
If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData 'si la feuille est filtrée
tablo = Range("B3:D" & Range("B" & Rows.Count).End(xlUp).Row + 2) 'matrice, plus rapide
Set d1 = CreateObject("Scripting.Dictionary")
Set d2 = CreateObject("Scripting.Dictionary")
'---RAZ---
dest.Resize(Rows.Count - dest.Row + 1, 4).ClearContents
dest.Resize(Rows.Count - dest.Row + 1, 4).Borders.LineStyle = xlNone
'---remplissage des Dictionary---
For i = 1 To UBound(tablo)
x = tablo(i, 1)
If x <> "" Then
d1(x) = d1(x) & IIf(d1.exists(x), ", ", "") & tablo(i, 2)
d2(x) = d2(x) + tablo(i, 3)
End If
Next
If d1.Count = 0 Then Exit Sub
'---restitution---
dest.Resize(d1.Count) = Application.Transpose(d1.keys)
dest(1, 2).Resize(d1.Count) = Application.Transpose(d1.items)
dest(1, 3).Resize(d1.Count) = Application.Transpose(d2.items)
dest(1, 4).Resize(d1.Count) = "=N(R[-1]C)+RC[-1]" 'cumul
dest(1, 4).Resize(d1.Count) = dest(1, 4).Resize(d1.Count).Value 'supprime les formules
dest.Resize(d1.Count, 4).Borders.Weight = xlThin 'bordurs
dest.Resize(, 4).EntireColumn.AutoFit 'ajustement largeurs
End Sub