查找范围内的特定文本并更改字体颜色

Question

我希望有人可以帮助我使用 VBA 代码来搜索单元格区域中的特定文本并将字体颜色更改为红色。 例如，我正在查找单词“cat”，但我不希望任何包含相同字母的其他单词发生变化，例如“concatenate”或“category”甚至“cats”。

我使用了以下内容，但它也拾取了包含相同字母的其他单词

Public Sub ChangefontColor()

Set TextRange = Range("K2:K4584")

partOfText = "CAT"

fontColor = 3

For Each part In TextRange

lenOfPart = Len(part)

lenPartOfText = Len(partOfText)

For i = 1 To lenOfPart

tempStr = Mid(part, i, lenPartOfText)

If tempStr = partOfText Then

part.Characters(Start:=i, Length:=lenPartOfText).Font.ColorIndex = fontColor

End If

Next i

Next part

End Sub

Answer 1

选项 1：

• preStr / postStr

  是一个字符

  before / after

  匹配部分（3 个字符）。
• 注意： 您的代码是区分大小写的比较。它与

  Cat

  或

  cat

  不匹配。
• 错误：下面的代码突出显示了

  CAT3

  中的关键字。使用

  RegExp

  是更可靠的选择。

Option Explicit
Public Sub ChangefontColor()
    Dim TextRange As Range, lenPartOfText As Long, lenOfPart As Long
    Dim tempStr As String, partOfText As String
    Dim postStr As String, preStr As String, part, i As Long
    Const FONT_COLOR = 3
    Set TextRange = Range("K2:K4584")
    TextRange.Font.Color = vbBlack
    partOfText = "CAT"
    lenPartOfText = Len(partOfText)
    For Each part In TextRange
        lenOfPart = Len(part)
        For i = 1 To lenOfPart - lenPartOfText + 1
            tempStr = Mid(part, i, lenPartOfText)
            If i < lenOfPart - lenPartOfText + 1 Then
                postStr = LCase(Mid(part, i + lenPartOfText, 1))
            Else
                postStr = ""
            End If
            If i = 1 Then
                preStr = ""
            Else
                preStr = LCase(Mid(part, i - 1, 1))
            End If
            If tempStr = partOfText Then
                If (Len(postStr) = 0 Or postStr < "a" Or postStr > "z") And _
                    (Len(preStr) = 0 Or preStr < "a" Or preStr > "z") Then
                    part.Characters(Start:=i, Length:=lenPartOfText).Font.ColorIndex = FONT_COLOR
                End If
            End If
        Next
    Next
End Sub

---

选项2：

Sub Demo()
    Dim j As Long, c As Range, textRange As Range
    Dim strTxt As String, strMatch As String, strNewTxt As String
    Dim objRegExp As Object, objMatch As Object
    Const FONT_COLOR = 3
    Const KEYWORD = "CAT"
    Set textRange = Range("K2:K4584")
    textRange.Font.Color = vbBlack
    ' Match and submatches
    Set objRegExp = CreateObject("vbscript.regexp")
    With objRegExp
        .Pattern = "\b" & KEYWORD & "\b"
        .Global = True
        .IgnoreCase = False
        For Each c In textRange
            strTxt = c.Value
            If .Test(strTxt) Then
                Set objMatch = .Execute(strTxt)
                For j = 0 To objMatch.Count - 1
'                    Debug.Print objMatch(j).firstIndex, strTxt
                    c.Characters(Start:=objMatch(j).firstIndex + 1, _
                    Length:=objMatch(j).Length).Font.ColorIndex = FONT_COLOR
                Next
            End If
        Next
    End With
End Sub