Sub Récupération()
Dim numech As Range, fichier$, d1 As Object, d2 As Object, t, i&, cles, n, a(), num
Set numech = [B3:D3] 'liste à adapter
fichier = ThisWorkbook.Path & "\" & [B6] 'à adapter éventuellement
Application.ScreenUpdating = False
Set d1 = CreateObject("Scripting.Dictionary")
Set d2 = CreateObject("Scripting.Dictionary")
Workbooks.OpenText fichier, Local:=True
t = ActiveWorkbook.Sheets(1).UsedRange.Resize(, 3)
ActiveWorkbook.Close
'---clés et items---
For i = 1 To UBound(t)
If t(i, 2) <> "" Then
d1(UCase(t(i, 2))) = ""
d2(t(i, 1) & UCase(t(i, 2))) = t(i, 3) 'mémorise la valeur en 3ème colonne
End If
Next i
If d1.Count = 0 Then Exit Sub 'sécurité
cles = d1.keys
'---tableaux des résultats (tableaux Excel)---
For n = 1 To 3
With ActiveSheet.ListObjects(n).DataBodyRange
.Delete xlUp 'RAZ
.Columns(1).Resize(d1.Count) = Application.Transpose(cles) 'Transpose est limitée à 65536 lignes
With .Columns(2).Resize(d1.Count)
ReDim a(1 To d1.Count, 1 To 1)
num = numech(n)
For i = 1 To UBound(a)
a(i, 1) = d2(num & cles(i - 1)) 'items
Next i
.Value = a
End With
End With
Next n
End Sub