根据单词列表将单词颜色更改为红色

Question

我有以下代码，可以将一个单词更改为不同的颜色。有没有一种方法可以将多个单词更改为不同的颜色，这样我就不必为100个不同的单词设置宏，然后运行宏100次？

例如，这是搜索单词"dog"时的代码。我能以某种方式加上"cat"吗？

Sub test()
    Dim changeRange As Range, oneCell As Range
    Dim testStr As String, seekstr As String
    Dim startPosition As String
    seekstr = "dog": Rem adjust
    Set changeRange = ThisWorkbook.Sheets("Sheet1").Range("A2:B21"): Rem adjust
    For Each oneCell In changeRange.Cells
        testStr = CStr(oneCell.Value)
        testStr = LCase(testStr): seekstr = LCase(seekstr): Rem For Case insensitive
        oneCell.Font.ColorIndex = xlAutomatic: Rem remove all colors
        startPosition = 1
        Do While 0 < InStr(startPosition, " " & testStr & " ", " " & seekstr & " ", 1)
            startPosition = InStr(startPosition, " " & testStr & " ", " " & seekstr & " ") + 1
            oneCell.Characters(startPosition - 1, Len(seekstr)).Font.ColorIndex = 3
        Loop
    Next oneCell
End Sub

Answer 1

处理一组宠物。到达每个单独的单元格后，循环遍历数组，测试每个值并根据需要调整文本颜色。

Sub test()
    Dim changeRange As Range, oneCell As Range
    Dim testStr As String, seekstr As String
    Dim startPosition As String
    Dim v As Long, vPETs As Variant
    vPETs = Array("dog", "cat", "hamster")
    Set changeRange = ThisWorkbook.Sheets("Sheet1").Range("A2:B21"): Rem adjust
    For Each oneCell In changeRange.Cells
        testStr = CStr(oneCell.Value)
        testStr = LCase(testStr): seekstr = LCase(seekstr): Rem For Case insensitive
        oneCell.Font.ColorIndex = xlAutomatic: Rem remove all colors
        For v = LBound(vPETs) To UBound(vPETs)
            seekstr = vPETs(v)
            startPosition = 1
            Do While 0 < InStr(startPosition, " " & testStr & " ", " " & seekstr & " ", 1)
                startPosition = InStr(startPosition, " " & testStr & " ", " " & seekstr & " ") + 1
                oneCell.Characters(startPosition - 1, Len(seekstr)).Font.ColorIndex = 3
            Loop
        Next v
    Next oneCell
End Sub