Поиск  Пользователи  Правила 
Закрыть
Логин:
Пароль:
Забыли свой пароль?
Регистрация
Войти
 
Страницы: 1
RSS
Поиск слова в ячейке и изменение цвета
 
Доброго времени зашедшим!

Суть вопроса такова: необходимо найти слово, например "цена" в ячейке и только у этого слова изменить цвет, скажем, на красный.

Расположение в тексте данного слова постоянно меняется.
Снимок.JPG (145.52 КБ)
 
Поиск вам в помощь https://www.planetaexcel.ru/forum/index.php?PAGE_NAME=read&FID=1&TID=66010
 
Цитата
Kuzmich написал:
Поиск вам в помощь  https://www.planetaexcel.ru/forum/index.php?PAGE_NAME=read&FID=1&TID=66010

Я не могу разобраться в том макросе.
 
Edgar-by,
Приложите пример в формате Excel
 
Вот пример:
 
Подправил макрос для вашего случая
Код
Sub iText()
Dim i As Long
Dim iLR As Long
Dim re As Object
Dim objMatches As Object
Dim objMatch As Object
  iLR = Cells(Rows.Count, "D").End(xlUp).Row
      Columns("D:D").Font.ColorIndex = 0
'  For i = 1 To iLR
      Set re = CreateObject("VBScript.RegExp")
         re.Global = True
         re.IgnoreCase = True
         re.Pattern = "цена"
        Set objMatches = re.Execute(Cells(7, "D"))
          If objMatches.Count <> 0 Then
             For j = 0 To objMatches.Count - 1
                Set objMatch = objMatches.Item(j)
                With Cells(7, "D").Characters(Start:=objMatch.FirstIndex + 1, Length:=objMatch.Length).Font
                    .ColorIndex = 3
                End With
             Next
          End If
        Set re = Nothing
'    Next
End Sub
 
Огромное спасибо! Работает! Только почему-то, когда я макрос добавив слово "этаж", то первое слово "цена" перестало быть красным...

Я думал, на основе этого кода, я смогу закрашивать несколько слов в ячейке, а не получается...
Изменено: Edgar-by - 26 окт 2020 22:45:06
 
Kuzmich, извините за наглость, подскажите, пожалуйста, что в этом макросе изменить, чтоб он несколько слов изменял?
 
Цитата
закрашивать несколько слов в ячейке, а не получается...
Попробуйте так
Код
Sub iTextColor()
Dim ptn
Dim i As Integer
Dim iLR As Long
Dim objMatch As Object
 With CreateObject("VBScript.RegExp")
   .Global = True
   .ignorecase = True
  iLR = Cells(Rows.Count, "D").End(xlUp).Row
      Columns("D:D").Font.ColorIndex = 0
      ptn = Array("цена", "этаж", "район")
    For i = 0 To UBound(ptn)
      .Pattern = ptn(i)
      If .test(Cells(7, "D")) Then
       Set objMatch = .Execute(Cells(7, "D"))(0)
           With Cells(7, "D").Characters(Start:=objMatch.FirstIndex + 1, Length:=objMatch.Length).Font
              .ColorIndex = 3
           End With
      End If
   Next
 End With
End Sub
 
Kuzmich, от всей души Благодарю Вас!
Страницы: 1
Читают тему (гостей: 1)
Наверх