Highlight Different Words with Different Colors

[burniksapwet]

Guys I found this code and would like help to update it please. This will currently highlight the words remove, removed, Removed, Remove, Removed: N/A to red in column N. I was hoping it can be updated to where I can look for other words and highlight them a different color rather than create multiple of this code to do those other things. For example I also want to search for the words add, added and have it highlighted in blue. Please help me be added to add as many words as needed to any type of color we need it to be. Thank you in advance.

Sub Macro1()
Dim sPos As Long, sLen As Long
Dim rng As Range
Dim findMe As String
Dim i As Integer
Dim t As Integer
Dim SearchArray

SearchArray = Array("remove", "removed", "Removed", "Remove", "Removed: N/A")

For t = 0 To UBound(SearchArray)

Set rng = Range("N2:N10000")
findMe = SearchArray(t)

For Each rng In rng
With rng
If rng.Value Like "*" & findMe & "*" Then
If Not rng Is Nothing Then
For i = 1 To Len(rng.Value)
sPos = InStr(i, rng.Value, findMe)
sLen = Len(findMe)

If (sPos <> 0) Then
rng.Characters(Start:=sPos, Length:=sLen).Font.Color = RGB(255, 0, 0)
rng.Characters(Start:=sPos, Length:=sLen).Font.Bold = True
i = sPos + Len(findMe) - 1
End If
Next i
End If
End If
End With
Next rng

 

[DanteAmor]

Try this:

Sub Macro1()
  Dim rng As Range
  Dim findMe As String
  Dim sPos As Long, sLen As Long, i As Long, t As Long
  Dim SearchArray As Variant, c1 As Variant, c2 As Variant, c3 As Variant
  
  Set rng = Range("N2", Range("N" & Rows.Count).End(3))
  c1 = RGB(255, 0, 0)   'red
  c2 = RGB(0, 255, 0)   'yellow
  c3 = RGB(0, 0, 255)   'blue
  SearchArray = Array("remove", c1, "removed", c1, "Removed: N/A", c1, _
                      "copy", c2, "copied", c2, "add", c3, "added", c3)
  
  For Each rng In rng
  
    For t = 0 To UBound(SearchArray) Step 2
      findMe = SearchArray(t)
      If LCase(rng.Value) Like "*" & LCase(findMe) & "*" Then
        For i = 1 To Len(rng.Value)
          sPos = InStr(i, rng.Value, findMe, vbTextCompare)
          sLen = Len(findMe)
          If sPos <> 0 Then
            rng.Characters(Start:=sPos, Length:=sLen).Font.Color = SearchArray(t + 1)
            rng.Characters(Start:=sPos, Length:=sLen).Font.Bold = True
            i = sPos + sLen - 1
          End If
        Next i
      End If
    Next t
    
  Next rng
End Sub

 

[bebo021999]

Does "remove" include "removed"?
Is it different between "It is removed" vs " It remove" ?
If it is not different, may be use "remove" only.
Try to post several text samples in column N, if code in #2 did not work.

 

[burniksapwet]

Does "remove" include "removed"?
Is it different between "It is removed" vs " It remove" ?
If it is not different, may be use "remove" only.
Try to post several text samples in column N, if code in #2 did not work.

Reason I listed it like that is the macro I initially listed is case and word specific. I want to catch all aspects of how the word "remove" is said on column N. Remove, remove, Removed, removed, etc. I did not create the code, I do not know how to do it, I just simply used what I found online and made it work for what we need. I think this works out for us so that we are not highlighting the things we dont need. Thank you.

 

[burniksapwet]

Try this:

Sub Macro1()
  Dim rng As Range
  Dim findMe As String
  Dim sPos As Long, sLen As Long, i As Long, t As Long
  Dim SearchArray As Variant, c1 As Variant, c2 As Variant, c3 As Variant
 
  Set rng = Range("N2", Range("N" & Rows.Count).End(3))
  c1 = RGB(255, 0, 0)   'red
  c2 = RGB(0, 255, 0)   'yellow
  c3 = RGB(0, 0, 255)   'blue
  SearchArray = Array("remove", c1, "removed", c1, "Removed: N/A", c1, _
                      "copy", c2, "copied", c2, "add", c3, "added", c3)
 
  For Each rng In rng
 
    For t = 0 To UBound(SearchArray) Step 2
      findMe = SearchArray(t)
      If LCase(rng.Value) Like "*" & LCase(findMe) & "*" Then
        For i = 1 To Len(rng.Value)
          sPos = InStr(i, rng.Value, findMe, vbTextCompare)
          sLen = Len(findMe)
          If sPos <> 0 Then
            rng.Characters(Start:=sPos, Length:=sLen).Font.Color = SearchArray(t + 1)
            rng.Characters(Start:=sPos, Length:=sLen).Font.Bold = True
            i = sPos + sLen - 1
          End If
        Next i
      End If
    Next t
   
  Next rng
End Sub

Thank you so much. This worked perfectly.

 

[DanteAmor]

Im glad to help yout, thanks for the feedback