Sub Récupération()
Dim numech As Range, dest As Range, fichier$, d1 As Object, d2 As Object, t, i&, cles, n, a(), num
Set numech = [B3:D3] 'liste à adapter
Set dest = [B8] 'à 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
If d1.Count = 0 Then Exit Sub 'sécurité
cles = d1.keys
'---tableaux des résultats---
Rows(dest.Row & ":" & Rows.Count).Clear
For n = 1 To numech.Count
'---titre---
If n > 1 Then Set dest = dest(1, 4)
dest.Resize(, 2).Merge
dest = "Echantillon " & n
With dest.MergeArea
.Interior.ColorIndex = 16
.Font.Size = 16
.Font.ColorIndex = 2 'police blanche
.Font.Bold = True 'gras
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Borders.Weight = xlThin
End With
'---1ère colonne (clés)---
With dest(2).Resize(d1.Count)
.Value = Application.Transpose(cles) 'Transpose est limitée à 65536 lignes
.Interior.ColorIndex = 16
.Font.Size = 16
.Font.ColorIndex = 2 'police blanche
.Font.Bold = True 'gras
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Borders.Weight = xlThin
End With
'---2ème colonne(items)---
With dest(2, 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))
Next
.Value = a
.Interior.ColorIndex = 19
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Borders.Weight = xlThin
End With
Next
End Sub