Как подсветить определенные слова в тексте ячейки Excel?

Question

Подскажите, плиз,нужно найти из текста с ячейки определенные слова, данный макрос не работает, так как слово находиться в тексте, а не отдельно. Например, в ячейке с текстом ...Team Licensing Subscription New.. не подсвечивает слово Subscription, хотя в заданном макросе оно есть. Подскажите, пожалуйста, как поправить. Возможно, какими -то звездочками, как это в ексель делается.Спасибо!

Sub FindAndSelect() 
    Dim Rng As Range 
    Dim n 
With Worksheets("TDSheet") 
    Set Rng = .Range("A1:A3000")
    For Each n In Rng
        Select Case n
            Case "teams"
                n.Interior.Color = 255
            Case "TechnicalSuit"
                n.Interior.Color = 255
            Case "Captivate"
                n.Interior.Color = 255
            Case "Subscription"
                n.Interior.Color = 255
                 Case "TechnicalSuit"
                n.Interior.Color = 255
                 Case "Creative Cloud"
                n.Interior.Color = 255
                 Case "renewal"
                n.Interior.Color = 255
                 Case "TLP"
                n.Interior.Color = 255
                Case "Stock"
                n.Interior.Color = 255
                Case "Dreamweave"
                n.Interior.Color = 255
                Case "CLP"
                n.Interior.Color = 255
                Case "Spark"
                n.Interior.Color = 255
                Case "FrameMaker"
                n.Interior.Color = 255
                Case "Premiere Pro"
                n.Interior.Color = 255
                Case "Illustrator"
                n.Interior.Color = 255
                Case "Fresco"
                n.Interior.Color = 255
                Case "InCopy"
                n.Interior.Color = 255
                Case "enterprise"
                n.Interior.Color = 255
                Case "Audition"
                n.Interior.Color = 255
                Case "InDesign"
                n.Interior.Color = 255
                Case "Flash"
                n.Interior.Color = 255
                Case "Dimension"
                n.Interior.Color = 255
                Case "Lightroom"
                n.Interior.Color = 255
                Case "Substance"
                n.Interior.Color = 255
                Case "After Effects"
                n.Interior.Color = 255
                Case "Photoshop"
                n.Interior.Color = 255
                Case "XD"
                n.Interior.Color = 255
                Case "Animate"
                n.Interior.Color = 255
                Case "Presenter"
                n.Interior.Color = 255
                Case "RoboHelp"
                n.Interior.Color = 255
        End Select
    Next n
End With

Answer 1

Есть похожий вопрос на английском: Highlighting searched words on Vba excel

Единственная разница, в том вопросе ищется одно слово.

Адаптируем код из этого вопроса, выделим его в процедуру, вынесем все искомые значения в массив и будем вызывать процедуру в цикле:

'Выделяет заданный текст в заданном диапазоне
'Адаптирован код из ответа на 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

Если нужно выделять слова вне зависимости от регистра («Teams», «xd» и др.), то можно исправить функцию поиска текста, читайте комментарии.

И наоборот, если нужно искать слова именно с таким регистром, то можно проставить MatchCase:=True.

В принципе список терминов для выделения можно хранить не в коде, а где-нибудь в самой книге Excel.

БЛОГ НА HUSL

Как подсветить определенные слова в тексте ячейки Excel?

Ответы (1 шт):