keyword search - a macros to change font color for specific key words (not entire cell)

Hi,

so my issue is this: i need to conduct keyword searches in excel and color the keywords a different color without changing the font color of the entire cell. now, i found some code from another thread that does this, but i cant seem to get it to work with more than 2 keywords. i need some help fine-tuning the provided code to do what i need it to do.

please see: http://www.excelforum.com/excel-gene...ain-color.html

the VBA code i used was this:

Option Explicit
Option Compare Text

Sub test()
    Dim myList, myColor, myPtn As String, r As Range, m As Object, x
    Columns(1).Font.ColorIndex = xlAutomatic
    myList = VBA.Array("Cat", "Mouse")  '<-- add more if needed
    myColor = VBA.Array(vbRed, vbBlue)  '<-- adjust as per myList(use Color value, not ColorIndex)
    myPtn = Join$(myList, Chr(2))
    With CreateObject("VBScript.RegExp")
        .Global = True
        .IgnoreCase = True
        .Pattern = "([\^\$\(\)\[\]\*\+\-\?\.\|])"
        myPtn = Replace(.Replace(myPtn, "\$1"), Chr(2), "|")
        .Pattern = "\b(" & myPtn & ")\b"
        For Each r In Range("a1", Range("a" & Rows.Count).End(xlUp))
            If .test(r.Value) Then
                For Each m In .Execute(r.Value)
                    x = Application.Match(m, myList)
                    If Not IsError(x) Then
                        r.Characters(m.firstindex + 1, m.Length).Font.Color = myColor(x - 1)
                    End If
                Next
            End If
        Next
    End With
End Sub

i was playing around with the example, the Cat_Mouse.xlsm, and when i modified the 'myList' and 'myColor' arrays, it does not work.

Cat_Mouse.xlsm

for example, i modified the code to add the word bat:

myList to = VBA.Array("Cat", "Mouse", "bat")
myColor = VBA.Array(vbRed, vbBlue, vbRed)

when i run the macros, the word "Bat" does not become colored red. interestingly enough, when i substitute the word "bat" for the word "hat" in the "myLIST array, the word "hat" does change to the red font. any ideas on why this is happening?

i am looking to use this code to address keywords in my excel file by coloring all key words red and i have more than 10 key words.

any help would be appreciated, thanks.

excellent find, stanleydgromjr!

i decided to use this code:

Sub ColorCertainWords()
  Dim X As Long, Position As Long, Cell As Range, Words As Variant, Parts() As String
  
  Words = Array("gross proceeds//red//3", _
                "market value//red//3", _
                "enhancing the value//red//3", _
                "used off//red//3")					'<-- add more if needed
                
  For Each Cell In Range("B1", Cells(Rows.Count, "B").End(xlUp))
    If Len(Cell.Value) Then
      For X = LBound(Words) To UBound(Words)
        Parts = Split(Words(X), "//")
        If UBound(Parts) >= 0 Then
          Position = InStr(1, Cell.Value, Parts(0), vbTextCompare)
          Do While Position
            With Cell.Characters(Position, Len(Parts(0))).Font
              .ColorIndex = Parts(2)
              .Bold = True
            End With
            Position = InStr(Position + 1, Cell.Value, Parts(0), vbTextCompare)
          Loop
        End If
      Next
    End If
  Next
  
End Sub

my question is how do i edit this code to work not only in column B but also column H (ie, look for all keywords in columns B and H)

would be really nice if i could figure out a way to modify this code to fit my needs. this code should alow me to paste my keywords in a separate sheet

Sub ColorCertainWords()
  Dim X As Long, Z As Long, LastRow As Long, Position As Long, Colors(1 To 3) As Long
  Dim Temp As String, Words As Variant, Cell As Range
  
  Const Red As Long = 3
  Const Green As Long = 4
  Const Blue As Long = 5
  
  Colors(1) = Red
  Colors(2) = Green
  Colors(3) = Blue
  
  For Each Cell In Sheets("Clauses").Range("B1", Sheets("Clauses").Cells(Rows.Count, "B").End(xlUp))
    If Len(Cell.Value) Then
      For X = 1 To 3
        LastRow = Sheets("Lists").Cells(Rows.Count, X).End(xlUp).Row
        Words = Range(Sheets("Lists").Cells(3, X), Sheets("Lists").Cells(LastRow, 3))
        If Not IsArray(Words) Then
          Temp = Words
          ReDim Words(1 To 1, 1 To 1)
          Words(1, 1) = Temp
        End If
        For Z = 1 To UBound(Words)
          Position = InStr(1, Cell.Value, Words(Z, 1), vbTextCompare)
          Do While Position
            With Cell.Characters(Position, Len(Words(Z, 1))).Font
              .ColorIndex = Colors(X)
              .Bold = True
            End With
            Position = InStr(Position + 1, Cell.Value, Words(Z, 1), vbTextCompare)
          Loop
        Next
      Next
    End If
  Next
  
End Sub

Sub test()
    Dim myList, myColor, myPtn As String, r As Range, m As Object, x
    Columns(1).Font.ColorIndex = xlAutomatic
    myList = VBA.Array("Cat", "Mouse")  '<-- add more if needed
    myColor = VBA.Array(vbRed, vbBlue)  '<-- adjust as per myList(use Color value, not ColorIndex)
    myPtn = Join$(myList, Chr(2))
    With CreateObject("VBScript.RegExp")
        .Global = True
        .IgnoreCase = True
        .Pattern = "([\^\$\(\)\[\]\*\+\-\?\.\|])"
        myPtn = Replace(.Replace(myPtn, "\$1"), Chr(2), "|")
        .Pattern = "\b(" & myPtn & ")\b"
        For Each r In Range("b:b,h:h").SpecialCells(2)
            If .test(r.Value) Then
                For Each m In .Execute(r.Value)
                    x = Application.Match(m, myList, 0)
                    If Not IsError(x) Then
                        r.Characters(m.firstindex + 1, m.Length).Font.Color = myColor(x - 1)
                    End If
                Next
            End If
        Next
    End With
End Sub

Originally Posted by jindon

Sub test()
    Dim myList, myColor, myPtn As String, r As Range, m As Object, x
    Columns(1).Font.ColorIndex = xlAutomatic
    myList = VBA.Array("Cat", "Mouse")  '<-- add more if needed
    myColor = VBA.Array(vbRed, vbBlue)  '<-- adjust as per myList(use Color value, not ColorIndex)
    myPtn = Join$(myList, Chr(2))
    With CreateObject("VBScript.RegExp")
        .Global = True
        .IgnoreCase = True
        .Pattern = "([\^\$\(\)\[\]\*\+\-\?\.\|])"
        myPtn = Replace(.Replace(myPtn, "\$1"), Chr(2), "|")
        .Pattern = "\b(" & myPtn & ")\b"
        For Each r In Range("b:b,h:h").SpecialCells(2)
            If .test(r.Value) Then
                For Each m In .Execute(r.Value)
                    x = Application.Match(m, myList, 0)
                    If Not IsError(x) Then
                        r.Characters(m.firstindex + 1, m.Length).Font.Color = myColor(x - 1)
                    End If
                Next
            End If
        Next
    End With
End Sub

hi Jindon,

thanks for your response. if i use that code, i still cant add more than 2 keywords to be searched. any ideas?

You should be able to add as many as you want.

e.g

    myList = VBA.Array("Cat", "Mouse", "xxx", "yyy")
    myColor = VBA.Array(vbRed, vbBlue, vbYellow, vbGreen)

how do i modify the code so that if my keyword was "cat" and my spreadsheet had the word "Cats" that it would show up as Cats

Try change the pattern to

        .Pattern = "\b(" & myPtn & ")"

This macro was created to format substrings in a selected range of cells in a single step:

hi,how to extract the highlighted keywords(e.g. cat,mouse) in the column J?
For example:
Column B Column J
Cats123 Cat
002Mouse123 Mouse
Mickey Mouse Mouse

Regards