Option Explicit
Sub Transpose()
Dim a, i As Long, j As Long, x, derLig As Long
Application.ScreenUpdating = False
With Sheets("Feuil1").Cells(1).CurrentRegion
a = .Value
With CreateObject("System.Collections.SortedList")
For i = 3 To UBound(a, 1)
'a(i, 3) = StrConv(a(i, 3), vbUpperCase)
.Item(a(i, 3)) = .Item(a(i, 3)) & Chr(2) & a(i, 1) & " " & a(i, 2)
derLig = Application.Max(derLig, _
UBound(Split(Mid$(.Item(a(i, 3)), 2), Chr(2))))
Next
ReDim a(1 To derLig + 2, 1 To .Count)
For i = 0 To .Count - 1
a(1, i + 1) = .GetKey(i)
Next
For i = 0 To .Count - 1
x = Split(Mid$(.GetByIndex(i), 2), Chr(2))
For j = 0 To UBound(x)
a(j + 2, i + 1) = x(j)
Next
Next
End With
'Résultat dans la même feuille
With .Offset(1, .Columns.Count + 5).Resize(UBound(a, 1), UBound(a, 2))
.CurrentRegion.Clear
.Value = a
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.BorderAround ColorIndex:=1, Weight:=xlThin
.Borders(xlInsideVertical).Weight = xlThin
With .Rows(1)
.BorderAround ColorIndex:=1, Weight:=xlThin
.Interior.ColorIndex = 15
End With
.Columns(1).Resize(, .Columns.Count).ColumnWidth = 8
End With
End With
Application.ScreenUpdating = True
End Sub