Sub Essai()
Dim a, i As Long, AL As Object, e
Application.ScreenUpdating = False
Set AL = CreateObject("System.Collections.ArrayList")
With Range("A1").CurrentRegion
a = .Value
With CreateObject("Scripting.Dictionary")
.CompareMode = 1
For i = 2 To UBound(a, 1)
If Not AL.Contains(a(i, 2)) Then AL.Add a(i, 2)
If Not .exists(a(i, 1)) Then
Set .Item(a(i, 1)) = _
CreateObject("Scripting.Dictionary")
End If
.Item(a(i, 1))(a(i, 2)) = a(i, 3)
Next
AL.Sort
ReDim a(1 To .Count + 1, 1 To AL.Count + 1)
For i = 0 To AL.Count - 1
a(1, i + 2) = AL(i)
Next
For i = 0 To .Count - 1
a(i + 2, 1) = .keys()(i)
For Each e In .items()(i).keys
a(i + 2, AL.IndexOf(e, 0) + 2) = IIf(.items()(i)(e) <> 0, .items()(i)(e), "")
Next
Next
End With
'Résultat sur la même feuille
With .Offset(, .Columns.Count + 3).Resize(UBound(a, 1), UBound(a, 2))
.CurrentRegion.Clear
.Value = a
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.BorderAround ColorIndex:=1, Weight:=xlThin
.Borders(xlInsideVertical).Weight = xlThin
.Rows(1).Offset(, 1).Resize(, .Columns.Count - 1).Interior.ColorIndex = 40
.Rows(1).BorderAround ColorIndex:=1, Weight:=xlThin
.Columns(1).Offset(1).Resize(.Rows.Count - 1).Interior.ColorIndex = 19
End With
End With
Application.ScreenUpdating = True
End Sub