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("B1").Value

    ' Указываем диапазон для поиска
    Set searchRange = ThisWorkbook.Sheets("Лист1").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

    ' Выводим найденные значения в ячейку C4
    If ct > 0 Then
    ThisWorkbook.Sheets("Лист1").Range("C4").Resize(ct, 1) = out
    End If
End Sub

    ' Выводим найденные значения в ячейку C4
    If ct > 0 Then

        With ThisWorkbook.Sheets("Лист1")
            .Range("C4", .Range("C4").End(xlDown)).ClearContents
            .Range("C4").Resize(ct, 1) = out
        End With

    End If