Bonjour,
Option Explicit
Sub test()
Dim a, i As Long, j As Long, w()
a = Sheets("NOMENCLATURE").[a6].CurrentRegion.Value
With CreateObject("Scripting.Dictionary")
For i = 7 To UBound(a, 1)
For j = 4 To UBound(a, 2) - 1
If a(i, j) <> "" Then
If Not .exists(a(i, 2)) Then
ReDim w(1 To 1, 1 To 1)
Else
w = .Item(a(i, 2))
ReDim Preserve w(1 To 1, 1 To UBound(w, 2) + 1)
End If
w(1, UBound(w, 2)) = a(2, j)
.Item(a(i, 2)) = w
End If
Next
Next
a = Sheets("Corresp").Range("a1").CurrentRegion.Value
For i = 1 To UBound(a, 1)
If .exists(a(i, 1)) Then
Sheets("Corresp").Cells(i, 2).Resize(, UBound(.Item(a(i, 1)), 2)).Value = .Item(a(i, 1))
End If
Next
End With
End Sub
klin89