Sub Essai()
Dim a, i As Long, n As Long
Application.ScreenUpdating = False
With Sheets("Feuil1")
a = .Range("E1").CurrentRegion.Value
With CreateObject("Scripting.Dictionary")
.CompareMode = 1
For i = 1 To UBound(a, 1)
If Not .exists(a(i, 1)) Then
n = n + 1
a(n, 1) = a(i, 1)
a(n, 2) = a(i, 5)
.Item(a(i, 1)) = n
Else
a(.Item(a(i, 1)), 2) = a(.Item(a(i, 1)), 2) & " " & a(i, 5)
End If
Next
ReDim Preserve a(1 To UBound(a, 1), 1 To 2)
For i = 1 To n
.Item(a(i, 1)) = Array(a(i, 1), a(i, 2))
Next
With Sheets("Feuil1")
a = .Range("A1").CurrentRegion
End With
ReDim Preserve a(1 To UBound(a, 1), 1 To 3)
For i = 1 To UBound(a, 1)
If .exists(a(i, 2)) Then
a(i, 3) = .Item(a(i, 2))(1)
End If
Next
End With
.Cells(1).Resize(UBound(a, 1), 3).Value = a
End With
Application.ScreenUpdating = True
End Sub