XL 2010 Comment réorganiser des données en lignes possédant des colonnes partiellement différentes

Sub Consolider()
Dim dest As Range, d As Object, LO As ListObject, nlig&, c As Range, n%
Dim tablo(), titres As Range, cc%, r As Range, i&, j%
With Feuil1 'CodeName de la feuille
    Set dest = .[I3] '1ère cellule des résultats, à adapter
    '---titres---
    Set d = CreateObject("Scripting.Dictionary")
    d.CompareMode = vbTextCompare 'la casse est ignorée
    For Each LO In .ListObjects
        nlig = nlig + LO.DataBodyRange.Rows.Count
        For Each c In LO.HeaderRowRange
            If Not d.exists(c.Value) Then n = n + 1: d(c.Value) = n
    Next c, LO
    dest.Resize(, n) = d.keys 'restitution
    '---tableau des valeurs---
    ReDim tablo(1 To nlig, 1 To n)
    For Each LO In .ListObjects
        Set titres = LO.HeaderRowRange
        cc = titres.Count
        For Each r In LO.DataBodyRange.Rows
            If r.Cells(1) <> "" Then
                i = i + 1
                For j = 1 To cc
                    tablo(i, d(titres(j).Value)) = r.Cells(j)
                Next j
            End If
    Next r, LO
    dest(2).Resize(nlig, n) = tablo 'restitution
End With
End Sub