XL 2016 Convertir une table avec vba

Bonjour le forum
j’essaye de transposer la première table sur le screenshot pour obtenir la deuxième avec vba sur des données de 30000 lignes. J’ai commencé avec ce code qui ne me fait pas exactement ce que je veux.
Je vous remercie d’avance pour votre précieuse aide


Sub ConvertTable()

Dim xArr1 As Variant

Dim xArr2 As Variant

Dim InputRng As Range, OutRng As Range

Dim xRows As Long

xTitleId = "convert"

Set InputRng = Application.Selection

Set InputRng = Application.InputBox("Range :", xTitleId, InputRng.Address, Type:=8)

Set OutRng = Application.InputBox("Out put to (single cell):", xTitleId, Type:=8)

Set OutRng = OutRng.Range("A1")

xArr1 = InputRng.Value

t = UBound(xArr1, 2): xRows = 1

With CreateObject("Scripting.Dictionary")

.CompareMode = 1

For i = 2 To UBound(xArr1, 1)

If Not .exists(xArr1(i, 1)) Then

xRows = xRows + 1: .Item(xArr1(i, 1)) = VBA.Array(xRows, t)

For ii = 1 To t

xArr1(xRows, ii) = xArr1(i, ii)

Next

Else

xArr2 = .Item(xArr1(i, 1))

If UBound(xArr1, 2) < xArr2(1) + t - 1 Then

ReDim Preserve xArr1(1 To UBound(xArr1, 1), 1 To xArr2(1) + t - 1)

For ii = 2 To t

xArr1(1, xArr2(1) + ii - 1) = xArr1(1, ii)

Next

End If

For ii = 2 To t

xArr1(xArr2(0), xArr2(1) + ii - 1) = xArr1(i, ii)

Next

xArr2(1) = xArr2(1) + t - 1: .Item(xArr1(i, 1)) = xArr2

End If

Next

End With

OutRng.Resize(xRows, UBound(xArr1, 2)).Value = xArr1

End Sub