Option Explicit
Sub test()
Dim x, a, b(), i As Long, j As Long, n As Long, temp, txt As String
With Sheets("data").Cells(1).CurrentRegion
a = .Value
x = Filter(.Parent.Evaluate("transpose(if(countif(offset(" & .Columns(3).Address & _
",,,row(1:" & .Rows.Count & "))," & .Columns(3).Address & ")=1, " & _
.Columns(3).Address & ",char(2)))"), Chr(2), 0)
ReDim b(1 To .Rows.Count, 1 To UBound(x) + 2)
b(1, 1) = "Identifiant": b(1, 2) = "Libellé"
For i = 1 To UBound(x)
b(1, i + 2) = x(i)
Next
With CreateObject("Scripting.Dictionary")
.CompareMode = 1
For i = 2 To UBound(a, 1)
txt = Join(Array(a(i, 1), a(i, 2)), Chr(2))
If Not .exists(txt) Then
.Item(txt) = .Count + 2
For j = 1 To 2
b(.Item(txt), j) = a(i, j)
Next
End If
temp = Application.Match(a(i, 3), x, 0)
b(.Item(txt), temp + 1) = b(.Item(txt), temp + 1) + a(i, 4)
Next
n = .Count + 1
End With
End With
Application.ScreenUpdating = False
'Restitution
With Sheets("synthèse").Cells(1)
.CurrentRegion.Clear
.Resize(n, UBound(b, 2)).Value = b
With .CurrentRegion
On Error Resume Next
.SpecialCells(4) = 0
On Error GoTo 0
.Cells(1).Resize(.Rows.Count, .Columns.Count).Sort key1:=.Cells(1), Header:=xlYes
With .Offset(.Rows.Count, 2).Resize(1, .Columns.Count - 2)
.Formula = "=sum(r2c:r[-1]c)"
End With
.Offset(.Rows.Count).Cells(1).Value = "Total"
End With
With .CurrentRegion
.Font.Name = "calibri"
.Font.Size = 10
.VerticalAlignment = xlCenter
.BorderAround Weight:=xlThin
.Borders(xlInsideVertical).Weight = xlThin
.Columns(1).NumberFormat = "000000"
With .Rows(1)
.Interior.ColorIndex = 44
.BorderAround Weight:=xlThin
End With
With .Rows(.Rows.Count)
.Interior.ColorIndex = 19
.BorderAround Weight:=xlThin
End With
.Columns("a:b").ColumnWidth = Array(12, 9)
End With
.Parent.Activate
End With
Application.ScreenUpdating = True
End Sub