transposer un tableau excel

Private Sub CommandButton1_Click()
Dim D As Object, Plg As Range, Cel As Range, L&, i&
Application.ScreenUpdating = False
L = 1
Set D = CreateObject("Scripting.Dictionary")
With Sheets("Feuil1")
    Set Plg = .Range(.Cells(3, 1), .Cells(Rows.Count, 1).End(xlUp))
    For Each Cel In Plg
        If Not D.Exists(Cel.Value) Then
            L = L + 1
            For i = 0 To 3
                Cells(L, Columns.Count).End(xlToLeft).Offset(0, 1) = _
                Cel.Offset(0, i).Value
            Next i
        Else
            For i = 1 To 3
                Cells(L, Columns.Count).End(xlToLeft).Offset(0, 1) = _
                Cel.Offset(0, i).Value
            Next i
        End If
        D(Cel.Value) = Cel.Value
    Next Cel
End With
Application.ScreenUpdating = False
End Sub

Sub test()
Dim c As Range, t As Integer

Application.ScreenUpdating = False
Set c = Range("A3")
Do While c(2, 1) <> ""
  If c(2, 1) = c Then
    c.Offset(1, 1).Resize(, 3).Copy Cells(c.Row, 256).End(xlToLeft)(1, 2)
    c(2, 1).EntireRow.Delete
  Else
    Set c = c(2, 1)
  End If
Loop
t = 5
Do While Application.WorksheetFunction.CountA(Columns(t)) > 0
  Cells(2, t) = Cells(2, (t - 2) Mod 3 + 2).Text & Int((t - 2) / 3)
  t = t + 1
Loop
Application.ScreenUpdating = True
End Sub

Private Sub CommandButton1_Click()
Dim D As Object, Plg As Range, Cel As Range, Temp As Variant, L&, i&
Application.ScreenUpdating = False
L = 1
Set D = CreateObject("Scripting.Dictionary")
With Sheets("Feuil1")
    Set Plg = .Range(.Cells(3, 1), .Cells(Rows.Count, 1).End(xlUp))
    For Each Cel In Plg
        If Not D.Exists(Cel.Value) Then
            L = L + 1
            Temp = .Range(Cel.Address, Cel.Offset(0, 3).Address).Value
            Cells(L, Columns.Count).End(xlToLeft).Offset(0, 1).Resize(1, 4) = Temp
            D(Cel.Value) = L
        Else
            Temp = .Range(Cel.Offset(0, 1).Address, Cel.Offset(0, 3).Address).Value
            Cells(D(Cel.Value), Columns.Count).End(xlToLeft).Offset(0, 1).Resize(1, 3) = Temp
        End If
    Next Cel
End With
Application.ScreenUpdating = True
End Sub

Private Sub CommandButton2_Click()
Dim D As Object, Plg As Range, Cel As Range, L%
Application.ScreenUpdating = False
Set D = CreateObject("Scripting.Dictionary")
With Sheets("Feuil1")
    Set Plg = .Range(.Cells(3, 1), .Cells(Rows.Count, 1).End(xlUp))
    For Each Cel In Plg
        L = 1
        If Not D.Exists(Cel.Value) Then
            D(Cel.Value) = D.Count + 2
            L = 0
        End If
        Cells(D(Cel.Value), Columns.Count).End(xlToLeft).Offset(0, 1).Resize(1, 4 - L) = _
        .Range(Cel.Offset(0, L).Address, Cel.Offset(0, 3).Address).Value
    Next Cel
End With
Application.ScreenUpdating = True
End Sub