Rangement vertical à partir de 2 colonnes

Sub test()
Dim Tablo(), Elmnt As Range, Nb1 As Long, Nb2 As Long
Set MonDico = CreateObject("Scripting.Dictionary")
Nb1 = Application.Count(Range("D5", [D65536].End(xlUp)))
Nb2 = Application.Max(Range("D5", [D65536].End(xlUp)))
ReDim Tablo(1 To Nb1 + 1, 1 To Nb2)
For i = 1 To Nb2
  Tablo(1, i) = i
Next
For Each Elmnt In Range("D5", [D65536].End(xlUp))
  If Not MonDico.Exists(Elmnt.Value) Then
    MonDico(Elmnt.Value) = 1
  Else: MonDico(Elmnt.Value) = MonDico(Elmnt.Value) + 1
  End If
  Tablo(MonDico(Elmnt.Value) + 1, Elmnt.Value) = Elmnt.Offset(0, 6).Value
Next
Range(Cells(1, 35), Cells(Nb1, 35 - 1 + Nb2)).Value = Tablo
End Sub