[a_axe]

Как себе это вижу я: »

blackeangel, почему не подходит стандартная функция "поиск и замена", она позволяет выполнять поиск по шаблону и заменять формат ячеек - хотите заливку, хотите цвет текста.

[blackeangel]

a_axe, часть текста поддерживается?

он красит всю ячейку, а надо только то что ищется. Только шаблон.а он может где угодно находиться в тексте ячейки.

[a_axe]

часть текста поддерживается »

нет, позволяет заменить форматирование всей ячейки.
Приложите файл, который будет содержать примеры текста, соответствующие шаблоны поиска и желаемый результат.

[blackeangel]

a_axe, пример

[Iska]

blackeangel, интересные Вы там шаблоны ищете .

Примерно так:

Скрытый текст

Код:

Option Explicit

Sub Sample()
    Dim strFindWhat As String
    Dim strFirstFoundAddress As String
    
    Dim objRange As Range
    
    Dim intFoundPosition As Integer
    
    
    strFindWhat = "ол"
    
    With ThisWorkbook.Worksheets.Item("Данные").UsedRange
        Set objRange = .Find( _
            What:=strFindWhat, _
            LookIn:=xlFormulas, _
            LookAt:=xlPart, _
            SearchOrder:=xlByRows, _
            SearchDirection:=xlNext, _
            MatchCase:=False, _
            SearchFormat:=False _
        )
        
        If Not objRange Is Nothing Then
            strFirstFoundAddress = objRange.Address
            
            Do
                intFoundPosition = InStr(1, objRange.Value, strFindWhat, vbTextCompare)
                
                Do While intFoundPosition > 0
                    objRange.Characters(intFoundPosition, Len(strFindWhat)).Font.Color = RGB(255, 0, 0)
                    intFoundPosition = InStr(intFoundPosition + 1, objRange.Value, strFindWhat, vbTextCompare)
                Loop
                
                Set objRange = .FindNext(After:=objRange)
            Loop Until objRange.Address = strFirstFoundAddress
        End If
    End With
End Sub

Естественно, вместо UsedRange Вы используете потребный Вам диапазон.

[blackeangel]

Iska, спасибо, отлично работает. Только вопрос, а на больших объемах данных долго думать будет?
Ну и не хватает

1) спрашиваем шаблон у юзера »

[Iska]

Только вопрос, а на больших объемах данных долго думать будет? »

Я не знаю количественное выражение «больших объёмов данных». Я не знаю конкретное количественное выражение понятия «долго». Посему не могу дать ответа на данный вопрос.

Ну и не хватает 1) спрашиваем шаблон у юзера »

Ну, добавьте InputBox вместо присвоения.

[blackeangel]

Iska, спасибо, так и сделал. Еще сделал запрос цвета для выделения.

Код:

Sub colorr()
    Dim strFindWhat As String
    Dim strFirstFoundAddress As String
    Dim objRange As Range
    Dim intFoundPosition As Integer
    strFindWhat = InputBox("Введите что подкрасить")
    sFontColorAsk = InputBox("Введите один из цветов: " _
    & Chr(13) & "черный, красный, зеленый, желтый," _
    & Chr(13) & "синий, пурпурный, циан, белый")
    If sFontColorAsk = "черный" Or sFontColorAsk = "Черный" Then sFontColor = vbBlack
    If sFontColorAsk = "красный" Or sFontColorAsk = "Красный" Then sFontColor = vbRed
    If sFontColorAsk = "зеленый" Or sFontColorAsk = "Зеленый" Then sFontColor = vbGreen
    If sFontColorAsk = "желтый" Or sFontColorAsk = "Желтый" Then sFontColor = vbYellow
    If sFontColorAsk = "синий" Or sFontColorAsk = "Синий" Then sFontColor = vbBlue
    If sFontColorAsk = "пурпурный" Or sFontColorAsk = "Пурпурный" Then sFontColor = vbMagenta
    If sFontColorAsk = "циан" Or sFontColorAsk = "Циан" Then sFontColor = vbCyan
    If sFontColorAsk = "белый" Or sFontColorAsk = "Белый" Then sFontColor = vbWhite
    With ActiveSheet.UsedRange
        Set objRange = .Find( _
            What:=strFindWhat, _
            LookIn:=xlFormulas, _
            LookAt:=xlPart, _
            SearchOrder:=xlByRows, _
            SearchDirection:=xlNext, _
            MatchCase:=False, _
            SearchFormat:=False _
        )
        If Not objRange Is Nothing Then
            strFirstFoundAddress = objRange.Address
            Do
                intFoundPosition = InStr(1, objRange.Value, strFindWhat, vbTextCompare)
                Do While intFoundPosition > 0
                    objRange.Characters(intFoundPosition, Len(strFindWhat)).Font.Color = sFontColor
                    intFoundPosition = InStr(intFoundPosition + 1, objRange.Value, strFindWhat, vbTextCompare)
                Loop
                Set objRange = .FindNext(After:=objRange)
            Loop Until objRange.Address = strFirstFoundAddress
        End If
    End With
End Sub

Если есть вариант проще, то это интересно.

[a_axe]

Если есть вариант проще, то это интересно. »

blackeangel, к программной реализации вопросов особенных нет, а вот взаимодействие с программой на мой взгляд можно построить следующим образом (я излагаю свое представление об удобстве, разумеется у вас оно может полностью не совпадать)

1. каждый раз вводить полное наименование цвета на мой взгляд неудобно. По хорошему можно сделать форму (одну - с текстовым окном и опциями выбора цвета), в которую вы сразу будете забивать свой поисковый шаблон и при необходимости - выбирать мышкой цвет.
При вводе через input я бы ограничился вводом первой буквы: не "красный", а просто "к". Кроме того, при наличии орфографической неточности (например "краный", или "Чёрный" вместо "Черный") соответствия найдено не будет, вполне можно принудительно присвоить в этом случае цвет (например черный) и предупредить об этом пользователя. Реализовать все вышеперечисленное можно через select case:

код Select case

Код:

Select Case LCase(sFontColorAsk)
        
        Case "к"
            sFontColor = vbRed
        Case "з"
            sFontColor = vbGreen
        Case "ж"
            sFontColor = vbYellow
        Case "с"
            sFontColor = vbBlue
        Case "п"
            sFontColor = vbMagenta
        Case "ц"
            sFontColor = vbCyan
        Case "б"
            sFontColor = vbWhite
        Case "ч"
            sFontColor = vbBlack
        Case Else
            sFontColor = vbBlack
            MsgBox "Цвет не распознан, применен черный"
    End Select

2. Введенный цвет следует не проверять в обоих регистрах (If sFontColorAsk = "черный" Or sFontColorAsk = "Черный"), а перевести в заданный(например нижний) регистр: LCase(sFontColorAsk). Это ускорит работу кода.
3.при вводе цвета текста нужно вставить значение по умолчанию, чтобы сократить количество ненужных действий (например красный):

код

Код:

sFontColorAsk = InputBox("Введите один из цветов: " _
    & Chr(13) & "черный (ч), красный (к),зеленый (з)," _
    & Chr(13) & "желтый (ж), синий (с), пурпурный (п), циан (ц), белый (б)", , "к")

Соответственно, код будет выглядеть следующим образом:

код

Код:

Sub colorr2()
    Dim strFindWhat As String
    Dim strFirstFoundAddress As String
    Dim objRange As Range
    Dim intFoundPosition As Integer
    strFindWhat = InputBox("Введите что подкрасить")
    sFontColorAsk = InputBox("Введите один из цветов: " _
    & Chr(13) & "черный (ч), красный (к),зеленый (з)," _
    & Chr(13) & "желтый (ж), синий (с), пурпурный (п), циан (ц), белый (б)", , "к")
    
    Select Case LCase(sFontColorAsk)
        
        Case "к"
            sFontColor = vbRed
        Case "з"
            sFontColor = vbGreen
        Case "ж"
            sFontColor = vbYellow
        Case "с"
            sFontColor = vbBlue
        Case "п"
            sFontColor = vbMagenta
        Case "ц"
            sFontColor = vbCyan
        Case "б"
            sFontColor = vbWhite
        Case "ч"
            sFontColor = vbBlack
        Case Else
            sFontColor = vbBlack
            MsgBox "Цвет не распознан, применен черный"
    End Select
    With ActiveSheet.UsedRange
        Set objRange = .Find( _
            What:=strFindWhat, _
            LookIn:=xlFormulas, _
            LookAt:=xlPart, _
            SearchOrder:=xlByRows, _
            SearchDirection:=xlNext, _
            MatchCase:=False, _
            SearchFormat:=False _
        )
        If Not objRange Is Nothing Then
            strFirstFoundAddress = objRange.Address
            Do
                intFoundPosition = InStr(1, objRange.Value, strFindWhat, vbTextCompare)
                Do While intFoundPosition > 0
                    objRange.Characters(intFoundPosition, Len(strFindWhat)).Font.Color = sFontColor
                    intFoundPosition = InStr(intFoundPosition + 1, objRange.Value, strFindWhat, vbTextCompare)
                Loop
                Set objRange = .FindNext(After:=objRange)
            Loop Until objRange.Address = strFirstFoundAddress
        End If
    End With
End Sub