CODEWITHSUNDEEP
excelvba
Sarah
Sarah

Reputation: 11

Changing word color to red based on list of words

I have the following code which allows me to change one word to a different color. Is there a way to change multiple words to different colors so I don't have to set up the macro for 100 different words, and then run the macro 100 different times?

For example - this is the code when searching for word 'dog'. Can I also add in 'cat' somehow? 

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

Upvotes: 1

Views: 341

Answers (1)

user4039065
user4039065

Reputation:

Work with an array of pets. After getting to each individual cell, cycle through the array, testing each value and adjusting the text color as necessary.

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

Upvotes: 2

Related Questions