Transposer des données en ligne

Private Sub Worksheet_Activate()
Dim P As Range, t, ncol%, d As Object, i&, resu(), lig&, s, j%
Set P = Feuil1.[A1].CurrentRegion 'CodeName de la feuille source
t = P 'matrice, plus rapide
If Not IsArray(t) Then GoTo 1
ncol = UBound(t, 2) - 1 'colonne identifiant non comptée
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
For i = 2 To UBound(t)
    d(t(i, 1)) = d(t(i, 1)) + 1 'comptage des doublons
Next i
If d.Count = 0 Then GoTo 1
ReDim resu(1 To d.Count, 1 To 1 + ncol * Application.Max(d.items))
d.RemoveAll
For i = 2 To UBound(t)
    If Not d.exists(t(i, 1)) Then
        lig = lig + 1
        d(t(i, 1)) = lig & " -1" 'repérage de la ligne
        resu(lig, 1) = t(i, 1)
    End If
    s = Split(d(t(i, 1))): s(1) = s(1) + 1
    d(t(i, 1)) = s(0) & " " & s(1)
    For j = 2 To ncol + 1
        resu(s(0), j + ncol * s(1)) = t(i, j)
Next j, i
'---restitution---
1 Application.ScreenUpdating = False
If AutoFilterMode Then ShowAllData 'si la feuille est filtrée
Cells.Delete 'RAZ
If lig = 0 Then Exit Sub
P(1).Resize(2).Copy [A1]
If ncol Then
    Set P = P.Rows(1).Resize(, ncol).Offset(, 1)
    For i = 1 To (UBound(resu, 2) - 1) / ncol
        P.Resize(2).Copy Cells(1, 2 + ncol * (i - 1)) '2 lignes copiées
        If i Mod 2 = 0 Then Cells(1, 2 + ncol * (i - 1)).Resize(, ncol).Interior.Color = vbGreen 'couleur alternée
    Next
End If
[A2].Resize(lig, UBound(resu, 2)) = resu 'restitution du tableau
If lig > 1 Then Rows(2).AutoFill Rows(2).Resize(lig), xlFillFormats 'copie les formats
Columns.AutoFit 'ajustement largeur
With UsedRange: End With 'actualise les barres de défilement
End Sub