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

[blackeangel]

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

[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. каждый раз вводить полное наименование цвета на мой взгляд неудобно. По хорошему можно сделать форму (https://yandex.ru/search/?text=%D1%81%D0%BE%D0%B7%D0%B4%D0%B0%D0%BD%D0%B8%D0%B5%20%D1%84%D0%BE%D1%80%D0%BC%20%D0%B2%20vba%20e xcel&lr=2&clid=2028026) (одну - с текстовым окном и опциями выбора цвета), в которую вы сразу будете забивать свой поисковый шаблон и при необходимости - выбирать мышкой цвет.
При вводе через input я бы ограничился вводом первой буквы: не "красный", а просто "к". Кроме того, при наличии орфографической неточности (например "краный", или "Чёрный" вместо "Черный") соответствия найдено не будет, вполне можно принудительно присвоить в этом случае цвет (например черный) и предупредить об этом пользователя. Реализовать все вышеперечисленное можно через 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

[blackeangel]

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?

[blackeangel]

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

[Iska]

Некрасиво.

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

[blackeangel]

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

Application.Dialogs(xlDialogEditColor).Show(intColorIndex, 255, 0, 0) »
и
Application.Dialogs(xlDialogEditColor).Show(20, 255, 0, 0)
это одно и тоже. то есть вы противоречите но и действительно меняет его. Это есть совсем нехорошо. »

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

[Iska]

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

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

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

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

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

да еще и возвращать тот цвет что не нужен, т.к. юзер его не выбирал? »
Это я пропустил при копировании. Должно быть, разумеется, не оставшийся по недосмотру «intResult», а «lngSelectedColor»:
btnGetColor.BackColor = lngSelectedColor 'назначаем цвет специально выделенной кнопке
(и если б Вы добавили приведённое в коде требование «Option Explicit» — сразу бы сие увидели). Приношу Вам свои извинения за недоработку.