キーワードリストのセル内のハイライト/カラーテキスト

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 

「セル」のセルの範囲が検索されています。

"LastMatchPos"は、最後に一致したキーワードが見つかった場所を覚えている変数で、追加の一致をその同じセルにさらに追加して見つけることができます。

Charactersは、セル全体ではなくセル内の文字を変更するために使用されます。

InStrが一致機能です。

UCase（大文字）は、キーワードとすべての大文字で検索されているテキストの両方を比較することで、大文字と小文字を区別しないように検索するキーワードとセルの両方に使用されます。

ここに完全なコードがあります。以下の2つの必要な機能をお見逃しなく。ここで

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 

上記のスクリプトを実行するために必要とされるカラーピッカーのための2つの機能、以下のとおりです。

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