Sub Regrouper()
Dim Fact, Livre, dicFact, dicLivre, Res, ref, fac
Dim i&, n&, k&
Application.ScreenUpdating = False
With Sheets("feuil1")
i = .Cells(.Rows.Count, "f").End(xlUp).Row
Livre = .Range("f5:g" & i).Value
i = .Cells(.Rows.Count, "b").End(xlUp).Row
Fact = .Range("b5:d" & i).Value
Set dicLivre = CreateObject("scripting.dictionary")
For i = 1 To UBound(Livre)
dicLivre(CStr(Livre(i, 1))) = dicLivre(CStr(Livre(i, 1))) + Livre(i, 2)
Next i
ReDim Res(1 To dicLivre.Count * UBound(Fact), 1 To 4)
n = 0
For Each ref In dicLivre.keys
Set dicFact = CreateObject("scripting.dictionary")
For k = 1 To UBound(Fact)
If CStr(Fact(k, 1)) = ref Then
dicFact(Fact(k, 2)) = dicFact(Fact(k, 2)) + Fact(k, 3)
End If
Next k
n = n + 1
Res(n, 1) = CLng(ref)
Res(n, 2) = dicLivre(ref)
n = n - 1
For Each fac In dicFact
n = n + 1
Res(n, 3) = fac
Res(n, 4) = dicFact(fac)
Next fac
Next ref
.Range("i5:L" & .Rows.Count).Clear
.Range("i5").Resize(n, 4) = Res
.Range("i5").Resize(n, 4).Borders.LineStyle = xlContinuous
.Range("i5").Offset(, 2).Resize(n, 2).Font.Color = RGB(255, 0, 0)
End With
End Sub