[решено] Выделить часть текста цветом в ячейке по шаблону на всем листе

Компьютерный форум OSzone.net (http://forum.oszone.net/index.php)

- Microsoft Office (Word, Excel, Outlook и т.д.) (http://forum.oszone.net/forumdisplay.php?f=115)

Выделить часть текста цветом в ячейке по шаблону на всем листе

Всем доброго вечера.
Есть интересная задача. Нужно выделить часть текста в ячейке которая запрашивается у пользователя.
Как себе это вижу я:
1) спрашиваем шаблон и цвет у юзера
2) присваиваем переменной и считаем длину (дальше пригодится)
3)цикл поиска на присутствие в ячейках шаблона(не в пустых ячейках)
4)считаем какой по счету символ начинается шаблон в найденой ячейке
5)дальше выполняем окрашивание в цвет(красный) (это есть в макрорекодере)

Цитата:

Цитата blackeangel

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

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

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

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

Цитата:

Цитата blackeangel

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

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

a_axe, пример

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 Вы используете потребный Вам диапазон.

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

Цитата:

Цитата blackeangel

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

Цитата:

Цитата blackeangel

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

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

Цитата:

Цитата blackeangel

Ну и не хватает

Цитата:

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

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

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

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

Цитата:

Цитата blackeangel

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

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

a_axe,

Код:

Private Sub UserForm_Initialize()

ComboBox1.List = Split("Черный,Красный,Зеленый,Желтый,Синий,Пурпурный,Циан,Белый", ",") 'заполняем выпадающее поле

End Sub



Private Sub CommandButton1_Click()

    Dim strFindWhat As String

    Dim strFirstFoundAddress As String

    Dim objRange As Range

    Dim intFoundPosition As Integer

    strFindWhat = Val(TextBox1.Text) 'забираем данные из текстового поля

    sFontColorAsk = ComboBox1.Text 'забираем данные из выпадающего поля

    

    If sFontColorAsk = "Черный" Then sFontcolor = vbBlack

    If sFontColorAsk = "Красный" Then sFontcolor = vbRed

    If sFontColorAsk = "Зеленый" Then sFontcolor = vbGreen

    If sFontColorAsk = "Желтый" Then sFontcolor = vbYellow

    If sFontColorAsk = "Синий" Then sFontcolor = vbBlue

    If sFontColorAsk = "Пурпурный" Then sFontcolor = vbMagenta

    If sFontColorAsk = "Циан" Then sFontcolor = vbCyan

    If 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

Теперь как уйти от If'ов?
Так же через Case?

a_axe, если интересно, то вот идея Ваша реализованная в UserForm. Получилось красиво)

Некрасиво.

1. Проверяйте возвращаемое значение методом .Show() и обрабатывайте только True:

Код:

If .Dialogs(xlDialogEditColor).Show(…) Then

    …

End If

2. Метод «.Dialogs(xlDialogEditColor).Show(40, …)» не просто показывает диалог выбора цвета для указанного индекса палитры Рабочей книги, но и действительно меняет его. Это есть совсем нехорошо. Посему недостаточно просто использовать данный метод и забыть про последствия. Необходимо предварительно сохранить текущий цвет из указанного индекса палитры, использовать метод, получить выбранный цвет, вернуть сохранённый цвет индексу палитры. Наподобие:

Код:

Option Explicit



Dim lngSelectedColor As Long                                  'переменная уровня модуля для использования её внутри формы



Private Sub btnGetColor_Click()

    Const intColorIndex = 40

    Dim lngPrevColor As Long

    

    

    lngPrevColor = ThisWorkbook.Colors(intColorIndex)

    

    If Application.Dialogs(xlDialogEditColor).Show(intColorIndex, 255, 0, 0) Then

        lngSelectedColor = ThisWorkbook.Colors(intColorIndex) 'получаем выбранный код цвета

        btnGetColor.BackColor = intResult                     'назначаем цвет специально выделенной кнопке

        ThisWorkbook.Colors(intColorIndex) = lngPrevColor

    End If

End Sub

Цитата:

Цитата Iska

1. Проверяйте возвращаемое значение методом .Show() и обрабатывайте только True: »

зачем?

Цитата:

Цитата Iska

2. Метод «.Dialogs(xlDialogEditColor).Show(40, …)» не просто показывает диалог выбора цвета для указанного индекса палитры Рабочей книги, но и действительно меняет его. Это есть совсем нехорошо »

Чем же это плохо? И потом,я создавал тему отдельно поэтому вопросу и там никто ничего не ответил.

Цитата:

Цитата Iska

Application.Dialogs(xlDialogEditColor).Show(intColorIndex, 255, 0, 0) »

Код:

Application.Dialogs(xlDialogEditColor).Show(20, 255, 0, 0)

это одно и тоже. то есть вы противоречите

Цитата:

Цитата Iska

но и действительно меняет его. Это есть совсем нехорошо. »

Цитата:

Цитата Iska

Необходимо предварительно сохранить текущий цвет из указанного индекса палитры, использовать метод, получить выбранный цвет, вернуть сохранённый цвет индексу палитры. »

зачем забор городить? да еще и возвращать тот цвет что не нужен, т.к. юзер его не выбирал?

Цитата:

Цитата blackeangel

зачем? »

Затем, что пользователь может нажать «Отмена».

Цитата:

Цитата blackeangel

Чем же это плохо? »

Тем что «поплывут» все места, где был использован данный индекс цвета палитры.

Цитата:

Цитата blackeangel

И потом,я создавал тему отдельно поэтому вопросу и там никто ничего не ответил. »

Не всё делается в то время, как Вам хочется, увы. У меня его тогда не было. Вы обратили внимание на время моего предыдущего сообщения? А этого? То-то.

Цитата:

Цитата blackeangel

это одно и тоже. »

Разумеется. Я просто заменил трёхкратное использование одного и того же постоянного числа константой. Но сие несущественно, и речь вовсе не об этом.

Цитата:

Цитата blackeangel

зачем забор городить?»

Затем, чтобы после отработки Вашего кода, внезапно не поменяли свои цвета ячейки рабочих листов и диаграммы.

Цитата:

Цитата blackeangel

да еще и возвращать тот цвет что не нужен, т.к. юзер его не выбирал? »

Это я пропустил при копировании. Должно быть, разумеется, не оставшийся по недосмотру «intResult», а «lngSelectedColor»:

Код:

        btnGetColor.BackColor = lngSelectedColor                     'назначаем цвет специально выделенной кнопке

(и если б Вы добавили приведённое в коде требование «Option Explicit» — сразу бы сие увидели). Приношу Вам свои извинения за недоработку.