Выделение/цвет текста внутри ячеек из списка ключевых слов

Question

В Excel У меня есть список ключевых слов (или фраз) в диапазоне ячеек и диапазон ячеек, которые, вероятно, содержат некоторые или все эти ключевые слова.

Как я могу автоматически выделить или изменить цвет текста, соответствующего любому из этих ключевых слов в пределах ячеек? Я не хочу выделить все ячейки, просто измените цвет совпадающих ключевых слов.

Answer 1

Вот сценарий VBA-Excel, который изменяет цвет совпадающего текста в ячейках, используя либо ряд ключевых слов/фраз для соответствия, либо ключевое слово/фразу, которые пользователь вводит при появлении запроса. Цвет текста можно выбрать из цветовой палитры, но по умолчанию используется красный.

код длинный, но вот короткая версия:

With cell.Characters(InStr(lastMatchPos, UCase(cell), UCase(keyword)), keywordLen).Font 
    .Color = SelectedColor ' color the keyword red 
    .Bold = True ' make the keyword bold 
End With 

«Cell» является диапазон ячейки разыскивается.

«LastMatchPos» - это переменная, которая запоминает, где было найдено последнее совпадение с ключевым словом, чтобы найти дополнительные совпадения в этой же ячейке.

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

InStr - соответствующая функция.

UCase (Upper Case) используется как для ключевого слова, так и для ячейки, которую нужно искать, чтобы сделать ее нечувствительной к регистру, сравнивая как ключевое слово, так и текст, поиск которого выполняется во всех кепках.

Вот полный код. Не пропустите две требуемые функции ниже.

Public keywordLen As Integer, matchCount As Integer, lastMatchPos As Integer, j As Integer 
Public SelectedColor As Long, i As Long, lastRow As Long 
Public searchRange As Range 
Public keywordType As String, keyword As String 
Public keywordRange As Variant 

Sub HighlightTextInCells() 
' This script prompts the user to select cells with keywords, 
' and then select cells to search in for those keywords. 
' 
' Variables are declared as Public, above this sub, so that 
' they are available to pass from userforms to the main sub. 
' 
' FUNCTIONS CALLED: 
' PickNewColor() 
'  Color2RGB() 


'Open custom userform 
    SelectKeywordRange.Show 

'Get the last used row on the worksheet to set as a limit for 
' how far the script will search. 
    lastRow = ActiveSheet.UsedRange.Rows.Count + ActiveSheet.UsedRange.Rows(1).Row - 1 

' Get user input. 
    On Error Resume Next 
     If Err.Number <> 0 Then Exit Sub 

     If keywordType = "range" Then 
      If InStr(keywordRange.Address, "$") Then 
       If IsNumeric(Mid(keywordRange.Address, InStrRev(keywordRange.Address, "$") + 1)) Then 
        For k = 1 To Len(keywordRange.Address) 
         If Mid(keywordRange.Address, InStr(keywordRange.Address, ":") + k, 1) <> "$" And IsNumeric(Mid(keywordRange.Address, InStr(keywordRange.Address, ":") + k, 1)) Then 
          If Mid(keywordRange.Address, InStr(keywordRange.Address, ":") + k) > lastRow Then 
           Set keywordRange = Range(Left(keywordRange.Address, InStrRev(keywordRange.Address, "$") - 1) & lastRow) 
           Exit For 
          End If 
         End If 
        Next k 
       Else 
        j = InStr(keywordRange.Address, ":") 
        Set keywordRange = Range(Left(keywordRange.Address, j - 1) & 1 & ":" & Mid(keywordRange.Address, j + 1) & lastRow) 
       End If 
      Else 
       manualKeyword = keywordRange 
      End If 
     End If 



     Set searchRange = Application.InputBox("Select the cells to search and highlight.", "SEARCH AREA", Type:=8) ' Prompt user to select cells to search and highlight. 
      If Err.Number <> 0 Then Exit Sub 

     If InStr(searchRange.Address, "$") Then 
      If IsNumeric(Mid(searchRange.Address, InStrRev(searchRange.Address, "$") + 1)) Then 
       For k = 1 To Len(searchRange.Address) 
        If Mid(searchRange.Address, InStr(searchRange.Address, ":") + k, 1) <> "$" And IsNumeric(Mid(searchRange.Address, InStr(searchRange.Address, ":") + k, 1)) Then 
         If Mid(searchRange.Address, InStr(searchRange.Address, ":") + k) > lastRow Then 
          Set searchRange = Range(Left(searchRange.Address, InStrRev(searchRange.Address, "$") - 1) & lastRow) 
          Exit For 
         End If 
        End If 
       Next k 
      Else 
       j = InStr(searchRange.Address, ":") 
       Set searchRange = Range(Left(searchRange.Address, j - 1) & 1 & ":" & Mid(searchRange.Address, j + 1) & lastRow) 
      End If 
     End If 



     SelectedColor = PickNewColor(255) ' Calls function "PickNewColor" with 255 (red) as the default 
      If Err.Number <> 0 Then Exit Sub 
    On Error GoTo 0 

' Check each cell in the user defined range for any of the keywords, and highlight them. 
    Application.Calculation = xlCalculationManual ' Stop calculating formulas during script 
    Application.ScreenUpdating = False ' Stop updating the screen during the script 


    If keywordType = "range" Then 
     For Each keyCell In keywordRange ' Loop through every keyword 
      keyword = keyCell.Value 
      keywordLen = Len(keyword) ' Get the length of the keyword for use later 

      If keywordLen > 1 Then ' Skip keywords that are blank or one character 

      ' For each keyword, loop through each cell in the search range looking for that keyword 
       For Each cell In searchRange.SpecialCells(xlCellTypeVisible) 
        matchCount = CountChrInString(UCase(cell), UCase(keyword)) 
        lastMatchPos = 1 
        ' Loop through a cell to find multiple instances of each keyword in that cell 
        For i = 1 To matchCount 
         If InStr(lastMatchPos, UCase(cell), UCase(keyword)) > 0 Then ' Use "UCase" to compare the keywords and the text being searched all uppercase, effectively NOT case sensitive. 
          ' Set the text formatting for matched keywords 
          With cell.Characters(InStr(lastMatchPos, UCase(cell), UCase(keyword)), keywordLen).Font 
           .Color = SelectedColor ' highlight the keyword red 
           .Bold = True ' make the keyword bold 
          End With 

          lastMatchPos = InStr(lastMatchPos, UCase(cell), UCase(keyword)) + 1 
         End If 
        Next i 
       Next cell 
      End If 
     Next keyCell 

    Else 
    'At this point, the keywordType <> "range", which means 
    ' the user typed a single keyword instead of a range 
    ' of keywords. 
     keyword = keywordRange 
     keywordLen = Len(keyword) ' Get the length of the keyword for use later 

     If keywordLen > 1 Then ' Skip keywords that are blank or one character 
     ' Loop through each cell in the search range looking for that keyword 
      For Each cell In searchRange.SpecialCells(xlCellTypeVisible) 
       If Len(cell.Value) > 0 Then 
        matchCount = CountChrInString(UCase(cell), UCase(keyword)) 
        lastMatchPos = 1 
        ' Loop through a cell to find multiple instances of each keyword in that cell 
        For i = 1 To matchCount 
         If InStr(lastMatchPos, UCase(cell), UCase(keyword)) > 0 Then ' Use "UCase" to compare the keywords and the text being searched all uppercase, effectively NOT case sensitive. 
          ' Set the text formatting for matched keywords 
          With cell.Characters(InStr(lastMatchPos, UCase(cell), UCase(keyword)), keywordLen).Font 
           .Color = SelectedColor ' highlight the keyword red 
           .Bold = True ' make the keyword bold 
          End With 

          lastMatchPos = InStr(lastMatchPos, UCase(cell), UCase(keyword)) + 1 
         End If 
        Next i 
       End If 
      Next cell 
     End If 
    End If 

    Application.Calculation = xlCalculationAutomatic ' Start calculating cell formulas again 
    Application.ScreenUpdating = True ' Start updating the screen again 
End Sub 

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

Function PickNewColor(Optional i_OldColor As Double = xlNone) As Double 
'Picks new color 
' THIS FUNCTION USES THE "Color2RGB" FUNCTION 
' 
    Const BGColor As Long = 13160660 'background color of dialogue 
    Const ColorIndexLast As Long = 32 'index of last custom color in palette 

    Dim myOrgColor As Double   'original color of color index 32 
    Dim myNewColor As Double   'color that was picked in the dialogue 
    Dim myRGB_R As Integer   'RGB values of the color that will be 
    Dim myRGB_G As Integer   'displayed in the dialogue as 
    Dim myRGB_B As Integer   '"Current" color 

     'save original palette color, because we don't really want to change it 
     myOrgColor = ActiveWorkbook.Colors(ColorIndexLast) 

     If i_OldColor = xlNone Then 
     'get RGB values of background color, so the "Current" color looks empty 
     Color2RGB BGColor, myRGB_R, myRGB_G, myRGB_B 
     Else 
     'get RGB values of i_OldColor 
     Color2RGB i_OldColor, myRGB_R, myRGB_G, myRGB_B 
     End If 

     'call the color picker dialogue 
     If Application.Dialogs(xlDialogEditColor).Show(ColorIndexLast, _ 
     myRGB_R, myRGB_G, myRGB_B) = True Then 
     '"OK" was pressed, so Excel automatically changed the palette 
     'read the new color from the palette 
     PickNewColor = ActiveWorkbook.Colors(ColorIndexLast) 
     'reset palette color to its original value 
     ActiveWorkbook.Colors(ColorIndexLast) = myOrgColor 
     Else 
     '"Cancel" was pressed, palette wasn't changed 
     'return old color (or xlNone if no color was passed to the function) 
     PickNewColor = "" 
     'PickNewColor = i_OldColor 
     End If 
End Function 

'Converts a color to RGB values 
' THIS FUNCTION IS USED BY THE "PickNewColor" FUNCTION 
Sub Color2RGB(ByVal i_Color As Long, o_R As Integer, o_G As Integer, o_B As Integer) 
    o_R = i_Color Mod 256 
    i_Color = i_Color \ 256 
    o_G = i_Color Mod 256 
    i_Color = i_Color \ 256 
    o_B = i_Color Mod 256 
End Sub