将VBA函数应用于指定文本列表，用于更改Excel中指定文本的字体颜色

Question

下面的代码更改Excel中所有指定字符串的字体颜色。

我想将其应用于多个指定的文本字符串，其中文本更改为的颜色对于所有提供的文本字符串都是相同的。

例如，与其查找cat的所有出现并将字体颜色更改为蓝色，不如将其应用于"；cat"狗"；，以及"；浣熊"；。

Sub SearchReplace_Color_PartialCell()
'modified to catch multiple occurences of search term within the single cell
Const textToChange = "cat"
Const newColor = vbBlue
Dim c As Range 'the cell we're looking at
Dim pos As Integer 'current position#, where we're looking in the cell (0 = Not Found)
Dim matches As Integer 'count number of replacements
For Each c In ActiveSheet.UsedRange.Cells 'loop throgh all cells that have data
pos = 1
Do While InStr(pos, c.Value, textToChange) > 0   'loop until no match in cell
matches = matches + 1
pos = InStr(pos, c.Value, textToChange)
c.Characters(InStr(pos, c.Value, textToChange), Len(textToChange)).Font.Color = _
newColor ' change the color of the text in that position
pos = pos + 1 'check again, starting 1 letter to the right
Loop
Next c
MsgBox "Replaced " & matches & " occurences of """ & textToChange & """"
End Sub

Answer 1

您只需要正则表达式来匹配整个单词，并且您可以使用搜索词数组。

例如：

Sub SearchReplace_Color_PartialCell()
Const newColor = vbBlue
Dim c As Range, pos, itm
Dim matches As Long, arrPos, v
For Each c In ActiveSheet.UsedRange.Cells 'loop throgh all cells that have data
v = c.Value
If Len(v) > 0 Then
For Each itm In Array("cat", "dog", "bear", "aardvark") '<<<< search terms
arrPos = ExactMatches(CStr(v), CStr(itm))
If Not IsEmpty(arrPos) Then
For Each pos In arrPos
c.Characters(pos, Len(itm)).Font.Color = newColor
matches = matches + 1
Next pos
End If 'got any matches
Next itm   'next search term
End If         'cell has a value
Next c
MsgBox "Replaced " & matches & " occurences "
End Sub
'Return an array of 1-based start positions for `lookFor` in `lookIn`
'  whole-word match only.   No return value if no matches.
Function ExactMatches(lookIn As String, lookFor As String) 'as array of start positions
Static re As Object 'persists between calls
Dim allMatches, m, i As Long

If re Is Nothing Then  'create if not already created
Set re = CreateObject("VBScript.RegExp")
re.ignorecase = True
re.Global = True
End If

re.Pattern = "b(" & lookFor & ")b"
Set allMatches = re.Execute(lookIn)
If allMatches.Count > 0 Then
ReDim arr(1 To allMatches.Count)
i = 0
For Each m In allMatches
i = i + 1
arr(i) = m.firstindex + 1 'report 1-based positions
Next m
ExactMatches = arr
End If
End Function