Sub FindAndMark()
    Dim lngI As Long, arrF() As String, intI As Integer, intJ As Integer
    Dim objRegExp As Object, objMatches As Object, objMatch As Object
    'пихаем в массив через сплит значения, введенные в inputbox (что ищем)
    arrF = Split(InputBox("разделите данные пробелом", "введите подстроки для поиска"), " ")
    'формируем объект регулярного выражения
    Set objRegExp = CreateObject("VBScript.RegExp")
    objRegExp.Global = True: objRegExp.IgnoreCase = True
    'счетаем количество заполненных строк в 1 столбце
    lngI = [a1].CurrentRegion.Rows.Count
    'если строка =1 да еще и пустая - ругаемся и выходим из процедуры
    If lngI = 1 And Cells(lngI, 1) = "" Then
        MsgBox "Негде искать. Введите данные в столбец А " & vbCr & "без разрывов, начиная с 1 строки"
        Exit Sub
    End If
    'запускаем цикл задом наперед по первому столбцу, крутим, пока счетчик не равен 0
    Do Until lngI = 0
        'запускаем цикл по каждому значению массива строк для поиска
        For intI = 0 To UBound(arrF)
        'стрку для поиска запихиваем в паттерн регулярки
        objRegExp.Pattern = arrF(intI)
        'если регулярка сработала (значение есть в ячейке)
        If objRegExp.test(Cells(lngI, 1)) Then
            'формируем объект совпадений в ячейке
            Set objMatches = objRegExp.Execute(Cells(lngI, 1))
            'для каждого совпадения
            For intJ = 0 To objMatches.Count - 1
                'формируем конкретный объект совпадения
                Set objMatch = objMatches.Item(intJ)
                'меняем шрифт совпадения на полужирный и красный
                With Cells(lngI, 1).Characters(Start:=objMatch.FirstIndex + 1, Length:=objMatches.Item(intJ).Length).Font
                    .Bold = True
                    .Color = vbRed
                End With
            Next intJ 'следующее совпадение
        End If
        Next intI 'следующая строка для поиска
        lngI = lngI - 1 'уменьшаем счетчик
    Loop
End Sub