Sub ТекстСлова()
    Dim sh As Worksheet
    Set sh = ActiveSheet
    With sh
        Dim arr As Variant
        Dim y As Long
        Dim u As Long
        Dim m As Long
        y = .Cells(.Rows.Count, 1).End(xlUp).Row
        m = .Cells(.Rows.Count, 2).End(xlUp).Row
        arr = .Range(.Cells(1, 1), .Cells(Application.Max(y, m), 3))
        
        Dim ou As Variant
        For y = 2 To UBound(arr, 1)
            For u = 2 To m
                If InStr(arr(y, 1), arr(u, 2)) > 0 Then
                    If Not IsEmpty(ou) Then
                        ReDim Preserve ou(0 To UBound(ou) + 1)
                    Else
                        ReDim ou(0 To 0)
                    End If
                    
                    ou(UBound(ou)) = arr(u, 2)
                End If
            Next
            If IsArray(ou) Then
                arr(y, 3) = Join(ou, ", ")
                Erase ou
                ou = Empty
            Else
                arr(y, 3) = Empty
            End If
        Next
        .Cells(1, 1).Resize(UBound(arr, 1), UBound(arr, 2)) = arr
    End With
End Sub