E
There's a similar question in English: https://stackoverflow.com/questions/35437207/highlighting-searched-words-on-vba-excel The only difference is, there's one word in the matter.Adapt the code from this issue, put it in the procedure, take all the required values into the body and cause the procedure in the cycle:'Выделяет заданный текст в заданном диапазоне
'Адаптирован код из ответа на Stack Overflow: https://stackoverflow.com/questions/35437207/highlighting-searched-words-on-vba-excel
Sub HighlighText(rng As Range, text As String)
Application.ScreenUpdating = False
Dim cellRange As Range
'Ищем текст на листе
Set cellRange = rng.Find(What:=text, LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not cellRange Is Nothing Then
Dim cellAddress As String
cellAddress = cellRange.Address
Do
Dim textStart As Integer
textStart = 1
Do
'Ищем текст внутри ячейки
'Если требуется поиск нечувствительный к регистру, то можно привести и искомое значение и текст к нижнему регистру
'textStart = InStr(textStart, LCase(cellRange.Value), LCase(text))
textStart = InStr(textStart, cellRange.Value, text)
If textStart <> 0 Then
'Выделяем текст
cellRange.Characters(textStart, Len(text)).Font.Color = RGB(255, 0, 0)
textStart = textStart + 1
End If
'Выделяем текст пока он находится в этой ячейке
Loop Until textStart = 0
Set cellRange = rng.FindNext(After:=cellRange)
Loop Until cellRange Is Nothing Or cellRange.Address = cellAddress
End If
End Sub
Sub FindAndSelect()
'Массив слов (терминов) для выделения
Dim termsToHighlight As Variant
termsToHighlight = Array("teams", "TechnicalSuit", "Captivate", "Subscription", "Creative Cloud", "renewal", "TLP", "Stock", "Dreamweave", "CLP", _
"Spark", "FrameMaker", "Premiere Pro", "Illustrator", "Fresco", "InCopy", "enterprise", "Audition", "InDesign", "Flash", "Dimension", _
"Lightroom", "Substance", "After Effects", "Photoshop", "XD", "Animate", "Presenter", "RoboHelp")
Dim workRange As Range
Set workRange = ActiveWorkbook.Worksheets("TDSheet").Range("A1:A3000")
For Each term In termsToHighlight
HighlighText workRange, CStr(term)
Next term
End Sub
If words are to be distinguished regardless of the register (Teams, xd etc.), the search function of the text can be corrected, read the comments.And vice versa, if you have to look for words with that register, you can put it. MatchCase:=True♪In principle, a list of terms for allocation can be stored somewhere in the Excel book rather than in the code.
