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