Find and highlight a specific word in a range of cells - excel

Question

I want to find a specific word in a range of cells then highlight it in red. To do so I created this code but it just worked on one line and highlighted all the cell text:
Sub Find_highlight()
Dim ws As Worksheet
Dim match As Range
Dim findMe As String
Set ws = ThisWorkbook.Sheets("MYSHEET")
findMe = "Background"
Set match = ws.Range("G3:G1362").Find(findMe)
match.Font.Color = RGB(255, 0, 0)
End Sub

Answer 1

Let's say your excel file looks like htis
To color specific word, you have to use the cell's .Characters property. You need to find where does the word start from and then color it.
Try this
Option Explicit
Sub Sample()
Dim sPos As Long, sLen As Long
Dim aCell As Range
Dim ws As Worksheet
Dim rng As Range
Dim findMe As String
Set ws = ThisWorkbook.Sheets("MYSHEET")
Set rng = ws.Range("G3:G1362")
findMe = "Background"
With rng
Set aCell = .Find(What:=findMe, LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not aCell Is Nothing Then
sPos = InStr(1, aCell.Value, findMe)
sLen = Len(findMe)
aCell.Characters(Start:=sPos, Length:=sLen).Font.Color = RGB(255, 0, 0)
End If
End With
End Sub
OUTPUT

Answer 2

i made some change to be more general and accurate
Option Explicit
Sub HIGHLIGHTER()
Dim sPos As Long, sLen As Long
Dim rng As Range
Dim findMe As String
Dim i As Integer
Set rng = Application.InputBox(Prompt:= _
"Please Select a range", _
Title:="HIGHLIGHTER", Type:=8)
findMe = Application.InputBox(Prompt:= _
"FIND WHAT?(YOU CAN USE PATTERN USED IN LIKE OPERATOR ", _
Title:="HIGHLIGHTER", Type:=2)
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)
i = sPos + Len(findMe) - 1
End If
Next i
End If
End If
End With
Next rng
End Sub

Answer 3

added an option to loop
Option Explicit
Sub Macro1()
Dim sPos As Long, sLen As Long
Dim aCell As Range
Dim ws As Worksheet
Dim rng As Range
Dim findMe As String
Set ws = ThisWorkbook.Sheets("Sheet2")
Set rng = ws.Range("A3:A322")
findMe = "find"
For Each rng In Selection
With rng
Set aCell = .Find(What:=findMe, LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not aCell Is Nothing Then
sPos = InStr(1, aCell.Value, findMe)
sLen = Len(findMe)
aCell.Characters(Start:=sPos, Length:=sLen).Font.Color = RGB(0, 255, 0)
End If
End With
Next rng
End Sub

Answer 4

I too made some changes to allow for searching multiple words at the same time. I also took away the prompts and hard coded the search words. The only issue left is to make the search non-case sensitive...
Sub HIGHLIGHTER()
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("WORD1", "WORD2")
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
Next t
End Sub