Transposer un tableau en regroupant les colonnes

Sub créa_tableau_transposé()
    Dim tab_transpo As Object, tab_col As Object
    Dim clé As Variant, donnée As String
    Dim i As Integer, nb_colonnes As Integer, nb_lignes As Integer
    Dim xl As Excel.Application
    Dim cell_départ As Range
    
    'stockage du tableau à transposer dans une collection de type dictionnaire
    Set tab_transpo = CreateObject("Scripting.Dictionary")
    With ActiveSheet.ListObjects("Tableau1")
        For i = 1 To .ListRows.Count
            clé = .ListColumns("colonne1").DataBodyRange.Rows(i)
            donnée = .ListColumns("colonne2").DataBodyRange.Rows(i)
            If Not tab_transpo.Exists(clé) Then
                Set tab_col = CreateObject("System.Collections.ArrayList")
                tab_col.Add donnée
                Set tab_transpo(clé) = tab_col
            Else
                Set tab_col = tab_transpo(clé)
                tab_col.Add donnée
                Set tab_transpo(clé) = tab_col
            End If
        Next i
    End With
    
    'création du tableau transposé à partir de la collection de type dictionnaire
    Set cell_départ = Range("E1")
    Set xl = Excel.Application
    nb_colonnes = tab_transpo.Count
    cell_départ.Resize(1, nb_colonnes).Value = xl.Transpose(xl.Transpose(tab_transpo.Keys))
    i = 0
    For Each clé In tab_transpo.Keys
        Set tab_col = tab_transpo(clé)
        nb_lignes = UBound(tab_col.ToArray) + 1
        cell_départ.Offset(1, i).Resize(nb_lignes, 1).Value = xl.Transpose(tab_col.ToArray)
        i = i + 1
    Next clé
    
    'création de la table Excel à partir du tableau transposé
    With ActiveSheet.ListObjects
        .Add(xlSrcRange, cell_départ.CurrentRegion, , xlYes).Name = "Tableau2"
    End With

End Sub

--