Sub ListeInverses()
Set f = Sheets("bdd")
Set d = CreateObject("Scripting.Dictionary")
Set d2 = CreateObject("Scripting.Dictionary")
For Each c In [B2].Resize(Application.CountA([b:b]))
tmp = c.Value & c.Offset(, 2)
If c.Value <> "" Then
If Not d2.exists(tmp) Then d(c.Value) = d(c.Value) & c.Offset(, 2) & "|": d2(tmp) = ""
End If
Next c
ligne = 1: col = 1
For Each c In d.keys
f.Cells(ligne, col) = c
a = Split(d.Item(c), "|")
f.Cells(ligne, col).Offset(1).Resize(UBound(a) + 1) = Application.Transpose(a)
col = col + 1
Next c
End Sub