Extract words from column A based on the list in column B | Solved

GEEK_21 

Run this macro:

Sub ListWords()
    Dim rng1 As Range
    Dim rng2 As Range
    Dim cel1 As Range
    Dim cel2 As Range
    Dim wrds() As String
    Dim wrd As Variant
    Dim s As String
    Dim dct As Object
    Application.ScreenUpdating = False
    Set rng1 = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
    Set rng2 = Range(Range("B1"), Range("B" & Rows.Count).End(xlUp))
    rng2.Offset(0, 1).ClearContents
    For Each cel2 In rng2
        s = cel2.Value
        Set dct = CreateObject(Class:="Scripting.Dictionary")
        For Each cel1 In rng1
            wrds = Split(cel1.Value)
            For Each wrd In wrds
                If InStr(1, wrd, s, vbTextCompare) Then
                    dct(wrd) = 1
                End If
            Next wrd
        Next cel1
        If dct.Count Then
            cel2.Offset(0, 1).Value = Join(dct.keys)
        End If
    Next cel2
    Application.ScreenUpdating = True
End Sub