VBA function for changing fontcolor of specified text in excel applied to a list of terms

GKunz 0
Viewed 35

I am trying to use VBA to change the font color of all occurances specified string of text in excel. The code below works great, but I would like to know if there is a way to apply it multiple specified string of text at the same time where the color to which the text is changed would be the same for all supplied text strings. For example rather thatn finding all occurances of cat and changing the font color to blue, it could be applied to both "cat", "dog", and "raccon".

Thank you for any assistance.

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
vba excel
1 Answers

You need regex to match on whole word only, and you can use an array of search terms.

For example:

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
useryB020
Related