Sub Find()
    On Error Resume Next: Err.Clear
    Dim ra As Range, cell As Range, res, txt$
    res = Sheets("Лист1").Range("A1") 'берем значение из ячейка А1 листа Лист1
    txt$ = Trim(res): If Len(txt) = 0 Then Exit Sub    ' текст не введен, или состоит из пробелов
    Set ra = Range([A1], Range("A" & Rows.Count).End(xlUp))    ' диапазон для поиска
    Application.ScreenUpdating = False
    ra.Font.Color = 0: ra.Font.Bold = 0  'сброс цветового выделения
    ra.Interior.Color = rgbWhite         'сброс заливки
    For Each cell In ra.Cells    ' перебираем все ячейки
        pos = 1
        If cell.Text Like "*" & txt & "*" Then
            arr = Split(cell.Text, txt, , vbTextCompare)   ' разбивает текст ячейки на части
            If UBound(arr) > 0 Then    ' если подстрока найдена
                cell.Interior.Color = rgbYellow 'заливка ячейки желтым
            End If
        End If
    Next cell
End Sub