Sub Calcul()
Dim dest As Range, tablo, sep$, d As Object, i&, x$, n&
tablo = [A1].CurrentRegion.Resize(, 4)
sep = ", " 'séparateur
Set d = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(tablo)
If tablo(i, 4) = 1 Then
x = tablo(i, 2)
If x <> "" Then
If d.exists(x) Then
d(x) = d(x) & sep & tablo(i, 1)
Else
d(x) = tablo(i, 1)
End If
End If
End If
Next
'---restitution---
n = d.Count
With [F2] '1ère cellule de destination, à adapter
If n Then
.Resize(n) = Application.Transpose(d.keys) 'Transpose est limitée à 65536 lignes
.Offset(, 1).Resize(n) = Application.Transpose(d.items)
End If
.Offset(n).Resize(Rows.Count - n - .Row + 1, 2).ClearContents 'RAZ en dessous
End With
End Sub