在Excel中，我有一系列单元格中的关键字（或短语）列表，以及可能包含部分或全部关键字的一系列单元格。
如何在单元格中自动突出显示或更改与中的任何关键字匹配的文字颜色？我不想突出显示整个单元格，只需更改匹配关键字的颜色。
答案 0 :(得分：0)
这是一个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（大写字母）用于搜索的关键字和单元格，通过比较关键字和所有大写字母中的搜索文本，使其不区分大小写。
这是完整的代码。不要错过以下两个必需的功能。
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