Sub extract()
Dim a, b
Dim i As Integer, j As Integer, n As Integer
a = Range("A2:A" & Cells(Rows.Count, "A").End(xlUp).Row)
b = Range("D2:D" & Cells(Rows.Count, "D").End(xlUp).Row)
ReDim c(1 To UBound(b, 1), 1 To 50)
Application.ScreenUpdating = False
For i = 1 To UBound(b, 1)
n = 1
c(i, 1) = i ' Order number
For j = 1 To UBound(a, 1)
If InStr(1, b(i, 1), a(j, 1)) Then ' Match Product
n = n + 1
c(i, n) = a(j, 1)
End If
Next j
Next i
[H2].Resize(100, 50).ClearContents
[H2].Resize(UBound(c, 1), UBound(c, 2)) = c
Application.ScreenUpdating = True
End Sub
Bookmarks