Sub Поиск()
Dim searchValue As String
Dim cell As Range, out(), ct&
Dim result As String
Dim searchRange As Range
' Получаем значение для поиска из ячейки B1
searchValue = ThisWorkbook.Sheets("Лист1").Range("B11").Value
' Указываем диапазон для поиска
Set searchRange = ThisWorkbook.Sheets("Лист2").Range("A1:A20")
ReDim out(1 To searchRange.Rows.Count, 1 To 1)
' Инициализируем переменную для хранения результата
result = ""
' Проходим по каждой ячейке в указанном диапазоне
For Each cell In searchRange
If InStr(1, cell.Value, searchValue, vbTextCompare) > 0 Then
' Если найдено совпадение, добавляем значение в результат
ct = ct + 1
out(ct, 1) = cell.Value
End If
Next cell
' Выводим найденные значения в ячейку C15
If ct > 0 Then
With ThisWorkbook.Sheets("Лист1")
.Range("C15", .Range("C15").End(xlDown)).ClearContents
.Range("C15").Resize(ct, 1) = out
End With
End If
End Sub