Sub ПоискТекста()
    On Error Resume Next: Err.Clear
    Dim ra As Range, cell As Range, res, txt$, v, pos&
    res1 = InputBox("Введите текст, который необходимо подсветить в таблице", "Поиск и подсветка текста", "текст")
    res2 = InputBox("Выбирите цвет текста", "Цвет выделения текста", "1-черн, 2-бел, 3-красн, 4-зел, 5-син, 6-жел,7 роз, 8-голуб, 9-корич")
    If VarType(res) = vbBoolean Then Exit Sub    ' нажата кнопка ОТМЕНА
    txt$ = Trim(res1): If Len(txt) = 0 Then Exit Sub    ' текст не введен, или состоит из пробелов
    Set ra = Range([A2], Range("A" & Rows.Count).End(xlUp))    ' диапазон для поиска
    Application.ScreenUpdating = False
    For Each cell In Selection    ' перебираем выделенные ячейки
        pos = 1
        If cell.Text Like "*" & txt & "*" Then
            arr = Split(cell.Text, txt, , vbTextCompare)   ' разбивает текст ячейки на части
            If UBound(arr) > 0 Then    ' если подстрока найдена
                For Each v In arr    ' перебираем все вхождения
                    pos = pos + Len(v)    ' начальная позиция
                    With cell.Characters(pos, Len(txt))
                        .Font.ColorIndex = res2
                        .Font.Bold = True    ' и полужирным начертанием
                    End With
                    pos = pos + Len(txt)
                Next v
            End If
        End If
    Next cell
End Sub