Find and highlight a specific word in a range of cells

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