Option Explicit
Sub test()
Dim a, i As Long, j As Long, n As Long, w()
ReDim w(1 To 3)
With Sheets("Feuil1").Range("A1").CurrentRegion
a = Application.Index(.Value, Evaluate("row(1:" & _
.Rows.Count & ")"), Array(1, 18, 19))
n = 1
With CreateObject("Scripting.Dictionary")
.CompareMode = 1
For i = 2 To UBound(a, 1)
If Not .exists(a(i, 1)) Then
n = n + 1
w(1) = n
For j = 2 To UBound(a, 2)
Set w(j) = _
CreateObject("Scripting.Dictionary")
w(j).CompareMode = 1
If (a(i, j)) <> "" Then
w(j)(a(i, j)) = Empty
End If
Next
For j = 1 To UBound(a, 2)
a(n, j) = a(i, j)
Next
.Item(a(i, 1)) = w
Else
w = .Item(a(i, 1))
For j = 2 To UBound(a, 2)
If a(i, j) <> "" Then
If Not w(j).exists(a(i, j)) Then
If a(w(1), j) <> "" Then
a(w(1), j) = Join$(Array(a(w(1), j), a(i, j)), " - ")
Else
a(w(1), j) = a(i, j)
End If
w(j)(a(i, j)) = Empty
.Item(a(i, 1)) = w
End If
End If
Next
End If
Next
End With
End With
'Restitution
Application.ScreenUpdating = False
With Sheets("Feuil3").Cells(1)
.CurrentRegion.Clear
.Parent.Columns("b:c").NumberFormat = "@"
With .Resize(n, UBound(a, 2))
.Value = a
.Font.Name = "Calibri"
.BorderAround Weight:=xlThin
.Borders(xlInsideVertical).Weight = xlThin
.Borders(xlInsideHorizontal).Weight = xlThin
.VerticalAlignment = xlCenter
.HorizontalAlignment = xlCenter
With .Rows(1)
.Interior.ColorIndex = 36
End With
.Columns.AutoFit
End With
.Parent.Activate
End With
Application.ScreenUpdating = True
End Sub