XL 2016 transposer des lignes en colonnes Excel 2016

Sub ventiler()
Dim dico, der&, t, i&, max&, j&, nlig&, nco&, s, x, y
With Sheets("test")
   Application.ScreenUpdating = False
   Set dico = CreateObject("scripting.dictionary"): dico.CompareMode = TextCompare
   If .FilterMode Then .ShowAllData
   der = .Cells(Rows.Count, "a").End(xlUp).Row
   .Range(.Range("a1"), .Cells(der, "b")).Sort key1:=Range("a1"), order1:=xlAscending, _
         key2:=Range("b1"), order2:=xlAscending, Header:=xlYes, MatchCase:=False
   t = .Range(.Range("a1"), .Cells(der, "b"))
   For i = 2 To UBound(t)
      dico(CStr(t(i, 1))) = dico(CStr(t(i, 1))) & "/" & t(i, 2)
   Next i
   For Each x In dico.Items
      j = Len(x) - Len(Replace(x, "/", ""))
      If j > max Then max = j
   Next x
   Erase t
   ReDim t(1 To max + 1, 1 To dico.Count)
   For Each x In dico.Keys
      nlig = 1: nco = nco + 1: t(nlig, nco) = x: s = Split(Mid(dico(x), 2), "/")
      For j = 0 To UBound(s)
         nlig = nlig + 1
         t(nlig, nco) = s(j)
      Next j
   Next x
   .Range("e1").CurrentRegion.Clear
   .Range("e1").Resize(UBound(t), UBound(t, 2)).NumberFormat = "@"
   .Range("e1").Resize(UBound(t), UBound(t, 2)) = t
   .Range("e1").CurrentRegion.Borders.LineStyle = xlContinuous
   .Range("e1").CurrentRegion.Rows(1).Font.Bold = True
   .Range("e1").CurrentRegion.Rows(1).Font.Color = RGB(0, 0, 255)
End With
End Sub

   .Range(.Range("a1"), .Cells(der, "b")).Sort key1:=Range("a1"), order1:=xlAscending, _
         key2:=Range("b1"), order2:=xlAscending, Header:=xlYes, MatchCase:=False

Sub mycode()
Application.ScreenUpdating = False
[E1:XFD1000].Clear
For k = 2 To [A65000].End(3).Row
cs = Cells(k, 1)
col = Application.Match(cs, [E1:XFD1], 0)
If IsNumeric(col) Then
bas = Cells(65000, col + 4).End(3).Row + 1
Cells(bas, col + 4) = Cells(k, 2)
Else
col = Application.CountA([E1:XFD1]) + 5
Cells(1, col) = Cells(k, 1)
Cells(2, col) = Cells(k, 2)
End If
Next
Application.ScreenUpdating = True
End Sub

Option Explicit
Sub test()
Dim a, b(), w(), i As Long, t As Long, maxRow As Long, dico as object
    Set dico = CreateObject("Scripting.Dictionary")
    dico.CompareMode = 1
    With Sheets("test").Range("a1").CurrentRegion
        a = .Value
        ReDim b(1 To UBound(a, 1), 1 To 1)
            For i = 2 To UBound(a, 1)
                If Not dico.exists(a(i, 1)) Then
                    t = t + 1
                    If t > UBound(b, 2) Then
                        ReDim Preserve b(1 To UBound(b, 1), 1 To t)
                    End If
                    b(1, t) = a(i, 1)
                    dico(a(i, 1)) = Array(1, t)
                End If
                w = dico(a(i, 1))
                w(0) = w(0) + 1
                b(w(0), w(1)) = a(i, 2)
                maxRow = Application.Max(maxRow, w(0))
                dico(a(i, 1)) = w
            Next
        .Offset(, .Columns.Count + 1).Resize(maxRow, UBound(b, 2)).Value = b
    End With
Set dico = nothing
End Sub