Quote Originally Posted by JohnTopley View Post
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
Is that a power query solution?