Find and highlight a specific word in a range of cells

Question

I want to find a specific word in a range of cells, and then highlight it in red. To do this, I created this code, but it just worked on one line and selected 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

Say your excel file looks like htis

To set the color of a specific word, you must use the cell property .Characters. You need to find where the word begins, and then its color.

try it

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

added option for 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 3

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 4

I also made some changes that let me search for multiple words at the same time. I also picked up the hints and encoded the search words. The only problem is making the search case insensitive ...

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