Доделать макрос поиска слов в фразах

[lybashevv]

Сообщений: 1
Репутация: 0 ±
Замечаний: 0% ±

Excel 2013
Здравствуйте помогите пожалуйста доделать макрос.
У меня есть макрос, который делает то что мне нужно, но не до конца.

Основной смысл, для чего мне макрос:
- есть 1 колонка со словами
- есть 2 колонка с фразами
- нужно найти фразы из 2 колонки в которых есть слова из 1 колонки
- и расположить фразы в которых содержится слово, напротив этого слова, таким образом как показано в примере

То что нужно доделать:
- слово и фраза, в которой оно найдено, были напротив друг друга,
- а напротив остальных фраз, в которых найдено слово(если фраза не одна), в 1 колонке была бы пустая ячейка
- и напротив слова из 1 столбца, которое не содержится ни в одной фразе из 2, была пустая ячейка в колонке 2

Код макроса:

Sub FindWords()
Dim fl As Boolean
Dim arrTemp2()
Dim arrTemp1()
    arrW = Range("B2:B" & Cells(Rows.Count, "B").End(xlUp).Row).Value
    arrPh = Range("D2 <img rel="usm" src="/sml2/biggrin.gif" border="0" align="absmiddle" alt=" <img rel="usm" src="/sml2/biggrin.gif" border="0" align="absmiddle" alt=":D" /> " /> " & Cells(Rows.Count, "D").End(xlUp).Row).Value
    For I = 1 To UBound(arrPh)
        fl = False
        For J = 1 To UBound(arrW)
            If arrPh(I, 1) Like "*" & arrW(J, 1) & "*" Then
                ReDim Preserve arrTemp1(I)
                arrTemp1(I) = arrPh(I, 1)
                fl = True
                Exit For
            End If
        Next
        If Not fl Then
            N = N + 1
            ReDim Preserve arrTemp2(N)
            arrTemp2(N) = arrPh(I, 1)
        End If
    Next
    Columns("D").ClearContents
    Range("D1").Resize(UBound(arrTemp1) + 1) = Application.Transpose(arrTemp1)
    Columns("F").ClearContents
    Range("F1").Resize(UBound(arrTemp2) + 1) = Application.Transpose(arrTemp2)
End Sub