Перебор значений для поиска

[RailOS]

Всем привет!
Сегодня столкнулся с задачей, с которой не мог разделаться при помощи макроса(за что и ненавидел себя около часа, пока делал это с помощью Ctrl+F)
Может вы поможете?
Сразу замечу, что программирование знаю плохо, но очень хотел бы научиться
Собственно все в приложенном файле

[R Dmitry]

Вы бы еще презентацию своих ошибок в powerpoint сотворили.
у вас с чем проблемы,С excel или с вордом?
если с excel то и свои баги выкладывайте в excel

[RailOS]

Сообщение от R Dmitry

Вы бы еще презентацию своих ошибок в powerpoint сотворили.
у вас с чем проблемы,С excel или с вордом?
если с excel то и свои баги выкладывайте в excel

Сорри)
вот оно

[nilem]

Что-то вроде этого

Sub Поиск_содеожимого()
Dim X As Range, Y As Range
Dim i As Integer

For Each Y In Range("B2:B6")
'If IsEmpty(Y) Then Exit For
i = 1
    For Each X In Range("A2:A20")
        If InStr(1, X, Y, vbTextCompare) > 0 Then Y.Offset(, i) = X: i = i + 1
    Next X
Next Y

End Sub

[doober]

Раз уж написал,выложу свой вариант

Sub Люби_Себя()
Dim Rez1, Rez2
Dim n As Long, m As Long
Rez1 = Sheets("Лист1").Range(("a1"), Sheets("Лист1").Range("a" & Rows.Count).End(xlUp))
Rez2 = Sheets("Лист1").Range(("b1"), Sheets("Лист1").Range("b" & Rows.Count).End(xlUp))
For n = 2 To UBound(Rez2)
For m = 2 To UBound(Rez1)
If InStr(1, Rez1(m, 1), Rez2(n, 1),vbTextCompare) > 0 Then
Sheets("Лист1").Cells(m, 3) = Rez1(m, 1)'Вариант1
Sheets("Лист1").Cells(n, 4) = Rez1(m, 1)'Вариант2 может пригодится
End If
Next
Next
End Sub

[RailOS]

Спасибо! Голова пока не варит, попробую вечером разобраться