Option Explicit
Sub test()
Dim a, b(), w(), i As Long, n As Long, maxRow As Long
a = Sheets("Feuil1").Range("b2").CurrentRegion.Value
ReDim b(1 To UBound(a, 2) + 1, 1 To 1)
With CreateObject("Scripting.Dictionary")
.CompareMode = 1
For i = 1 To UBound(a, 2)
If Not .exists(a(1, i)) Then
n = n + 1
If n > UBound(b, 2) Then
ReDim Preserve b(1 To UBound(b, 1), 1 To n)
End If
b(1, n) = a(1, i)
.Item(a(1, i)) = VBA.Array(1, n)
End If
w = .Item(a(1, i))
w(0) = w(0) + 1
b(w(0), w(1)) = a(2, i)
maxRow = Application.Max(maxRow, w(0))
.Item(a(1, i)) = w
Next
End With
Application.ScreenUpdating = False
'Restitution et mise en forme
With Sheets("Feuil2")
.Cells.Clear
With .Range("a1").Resize(maxRow, UBound(b, 2))
.Value = b
.Font.Name = "calibri"
.Font.Size = 10
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.BorderAround Weight:=xlThin
.Borders(xlInsideVertical).Weight = xlThin
With .Rows(1)
.WrapText = True
.RowHeight = 30
.Interior.ColorIndex = 42
.BorderAround Weight:=xlThin
End With
.Columns.ColumnWidth = 11
End With
.Activate
End With
Application.ScreenUpdating = True
End Sub