Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [H1]) Is Nothing Then Exit Sub
Dim dat, dest As Range, d As Object, dd As Object, tablo, i&, x$, titre, ncol%, j%, a
dat = [H1]
Set dest = [H4] '1ère cellule de destination
'---tableau source---
Set d = CreateObject("Scripting.Dictionary")
Set dd = CreateObject("Scripting.Dictionary")
tablo = [Tableau2] 'tableau structuré
For i = 1 To UBound(tablo)
x = tablo(i, 2) & " ; " & tablo(i, 3)
d(x) = ""
x = x & tablo(i, 5) & tablo(i, 4) & tablo(i, 1)
If Not dd.exists(x) Then dd(x) = tablo(i, 6)
Next i
If d.Count = 0 Then GoTo 1
'---tableau des titres---
titre = [H2:AF3] 'à adapter
ncol = UBound(titre, 2)
For j = 2 To ncol
If titre(1, j) = "" Then titre(1, j) = titre(1, j - 1) 'remplit les cellules vides
Next j
'---tableau des résultats---
tablo = dest.Resize(d.Count, ncol)
a = d.keys
For i = 1 To UBound(tablo)
tablo(i, 1) = a(i - 1)
For j = 2 To ncol
tablo(i, j) = dd(tablo(i, 1) & titre(2, j) & titre(1, j) & dat)
Next j, i
'---restitution---
With dest.Resize(d.Count, ncol)
.Value = tablo
.Borders.Weight = xlThin
.Columns(1).Interior.Color = 16772300 'bleu
End With
'---RAZ en dessous---
1 dest.Offset(d.Count).Resize(Rows.Count - d.Count - dest.Row + 1, ncol).Delete xlUp
With UsedRange: End With 'actualise la barre de défilement verticale
End Sub