Sub aaa()
Dim arr(), dd(), a&, b&, c&, x&
With ActiveSheet
  a = .Cells(.Rows.Count, "A").End(xlUp).Row
  b = Application.CountA(Intersect(.Rows(1), .UsedRange))
  c = Application.CountA(Intersect(.Rows(2), .UsedRange))
  dd = .Range(.Cells(1, 1), .Cells(a, c)).Value
  ReDim arr(1 To b, 1 To c)
  For a = 1 To c
    x = 1
    For c = 1 To b
      If InStr(dd(1, c), dd(2, a)) Then arr(x, a) = dd(1, c): x = x + 1
    Next
  Next
  .Cells(UBound(dd) + 1, 1).Resize(UBound(arr), UBound(arr, 2)) = arr
End With
End Sub

Sub qwer()
Dim s() As String
    For n = 1 To Cells(1, Columns.Count).End(xlToLeft).Column
        s1 = Cells(1, n).Value
        If Len(s1) = 0 Then Exit Sub
        s = Split(s1, "-")
        If UBound(s) = 0 Then s = Split(s1, " ")
        If UBound(s) = 0 Then s1 = s(0) Else s1 = s(1)
        n2 = 4
        For i2 = 1 To Cells(2, Columns.Count).End(xlToLeft).Column
            If s1 Like "*" & Cells(2, i2) & "*" Then
                Cells(n2, n).Value = Cells(3, i2).Value
                n2 = n2 + 1
            End If
        Next
    Next
End Sub