Sub Immatriculations()
Dim col1, col2, ub&, tablo1, tablo2, i&, d, j As Byte, im$, k&
col1 = Feuil1.Range("A5", Feuil1.[A65536].End(xlUp))
col2 = Feuil2.Range("E5", Feuil2.[E65536].End(xlUp))
ub = UBound(col2)
ReDim tablo1(1 To UBound(col1), 1 To 6)
tablo2 = Feuil2.[F5].Resize(ub, 6)
For i = 1 To UBound(col1)
d = col1(i, 1)
For j = 1 To 6
im = ""
For k = 1 To ub
If d <> "" And d = tablo2(k, j) Then _
im = im & vbLf & col2(k, 1)
Next
If im <> "" Then tablo1(i, j) = Mid(im, 2)
Next
Next
With Feuil1.[B5].Resize(UBound(tablo1), 6)
.Value = tablo1
.WrapText = True 'renvoi à la ligne
.Rows.AutoFit 'ajustement automatique
End With
End Sub