Search Keywords and Highlight in different colors

[gibson8]

how do I make a VBA to search a few times with different highlight color?
For example, the first time I search is "AS", then all results with "AS" will be highlighted in yellow.
Then the second time, I search is "BD", then all results with "BD" will be highlighted in green.
Then the 3rd, I search is "NE", then all results with "NE" will be highlighted in red.
.....
.....
.....
Until 8 times, then all highlight will be cleared/removed after that. And a perfect loop start, the first search of anything will be highlighted in yellow.

and

then how do i make the highlight area, not only in the exact cell but also the 3 cells next to it?

The below is my code. Please advice.

Sub FindRange()
Dim xRg As Range
Dim xFRg As Range
Dim xStrAddress As String
Dim xVrt As Variant
Dim xRow As Long

xVrt = Application.InputBox(prompt:="Search:", Title:="SearchKeyword")

If xVrt <> "" Then
Set xFRg = ActiveSheet.Cells.Find(what:=xVrt)
If xFRg Is Nothing Then
MsgBox prompt:="Cannot find this value", Title:="SearchKeyword"
Exit Sub
End If

xStrAddress = xFRg.Address
Set xRg = xFRg
Do
Set xFRg = ActiveSheet.Cells.FindNext(After:=xFRg)
Set xRg = Application.Union(xRg, xFRg)

   
Loop Until xFRg.Address = xStrAddress
If xRg.Count > 0 Then
xRg.EntireRow.Interior.ColorIndex = 8

End If
End If
End Sub

 

[CephasOz]

Does this do what you want?

Sub FindRange()
    Const cstrTitle As String = "Search Keyword"
    Static lngIndex As Long
    Dim xFRg As Range
    Dim xStrAddress As String
    Dim xVrt As Variant
    Dim varColours() As Variant
    Dim bolFound As Boolean
    
    bolFound = False
    xVrt = Application.InputBox(Prompt:="Search for:", Title:=cstrTitle)
    
    If (xVrt <> vbNullString) Then
        Set xFRg = ActiveSheet.Cells.Find(What:=xVrt)
        If (xFRg Is Nothing) Then
            MsgBox Prompt:="Cannot find this value", Title:=cstrTitle
        Else
            bolFound = True
            xStrAddress = xFRg.Address
            varColours = Array(vbYellow, vbWhite, vbRed, vbMagenta, vbGreen, vbCyan, vbBlue, vbBlack)
            Do While (Not (xFRg Is Nothing))
                Range(xFRg, xFRg.Offset(0, 3)).Interior.Color = varColours(lngIndex)
                Set xFRg = ActiveSheet.Cells.FindNext(After:=xFRg)
                If (xFRg.Address = xStrAddress) Then
                    Exit Do
                End If
            Loop
        End If
    End If
    If bolFound Then
        lngIndex = ((lngIndex + 1) Mod 8)
    End If
End Sub

 

[gibson8]

Does this do what you want?

Sub FindRange()
    Const cstrTitle As String = "Search Keyword"
    Static lngIndex As Long
    Dim xFRg As Range
    Dim xStrAddress As String
    Dim xVrt As Variant
    Dim varColours() As Variant
    Dim bolFound As Boolean
   
    bolFound = False
    xVrt = Application.InputBox(Prompt:="Search for:", Title:=cstrTitle)
   
    If (xVrt <> vbNullString) Then
        Set xFRg = ActiveSheet.Cells.Find(What:=xVrt)
        If (xFRg Is Nothing) Then
            MsgBox Prompt:="Cannot find this value", Title:=cstrTitle
        Else
            bolFound = True
            xStrAddress = xFRg.Address
            varColours = Array(vbYellow, vbWhite, vbRed, vbMagenta, vbGreen, vbCyan, vbBlue, vbBlack)
            Do While (Not (xFRg Is Nothing))
                Range(xFRg, xFRg.Offset(0, 3)).Interior.Color = varColours(lngIndex)
                Set xFRg = ActiveSheet.Cells.FindNext(After:=xFRg)
                If (xFRg.Address = xStrAddress) Then
                    Exit Do
                End If
            Loop
        End If
    End If
    If bolFound Then
        lngIndex = ((lngIndex + 1) Mod 8)
    End If
End Sub

Thank you so much for the help CephasOz.
it is great to know an expert like you.
Especially it is brilliant to set:

Static lngIndex As Long

 

[CephasOz]

Welcome to the board @gibson8 - I was glad to help.

 

[gibson8]

Welcome to the board @gibson8 - I was glad to help.

Sorry to bother you again, if i would like to remove all specific highlight color, but without removing others normal highlight. How should i select it all in the below code.

Sub RemoveSpecificHighlight()
Dim cell As Range
Dim varColours As Variant
Static lngIndex As Long

Application.ScreenUpdating = False

varColours = Array(RGB(255, 50, 50), RGB(0, 230, 0), RGB(0, 204, 255), RGB(250, 250, 0), RGB(250, 0, 250), RGB(48, 150, 99), RGB(190, 190, 190), RGB(205, 205, 255))

For Each cell In ActiveSheet.UsedRange

If cell.Interior.Color = varColours(lngIndex) Then

cell.Interior.Color = xlNone

End If

Next cell

End Sub

 

[CephasOz]

Modifying your code:

Sub RemoveSpecificHighlight()
    Dim rngCell As Range
    Dim varColours As Variant
    Dim lngIndex As Long
    Dim lngBtm As Long
    Dim lngTop As Long
    '
    Application.ScreenUpdating = False
    '
    varColours = Array(RGB(255, 50, 50), RGB(0, 230, 0), RGB(0, 204, 255), RGB(250, 250, 0), RGB(250, 0, 250), RGB(48, 150, 99), RGB(190, 190, 190), RGB(205, 205, 255))
    lngBtm = LBound(varColours)
    lngTop = UBound(varColours)
    For Each rngCell In ActiveSheet.UsedRange.Cells
        If (rngCell.Interior.Color <> xlNone) Then
            For lngIndex = lngBtm To lngTop
                If rngCell.Interior.Color = varColours(lngIndex) Then
                    rngCell.Interior.Color = xlNone
                    Exit For
                End If
            Next lngIndex
        End If
    Next rngCell
    '
    Application.ScreenUpdating = True
    '
End Sub

With turning off ScreenUpdating, always make sure that you turn it back on afterwards, otherwise it can get very frustrating. Also, try to avoid using reserved words as variable names, as you can encounter bugs that are very difficult to sort out (that's why I changed your "cell" to "rngCell").

 

[CephasOz]

Apologies - VBA isn't straight-forward when it comes to colors. Use this instead:

Sub RemoveSpecificHighlight()
    Dim rngCell As Range
    Dim varColours As Variant
    Dim lngIndex As Long
    Dim lngBtm As Long
    Dim lngTop As Long
    '
    Application.ScreenUpdating = False
    '
    varColours = Array(RGB(255, 50, 50), RGB(0, 230, 0), RGB(0, 204, 255), RGB(250, 250, 0), RGB(250, 0, 250), RGB(48, 150, 99), RGB(190, 190, 190), RGB(205, 205, 255))
    lngBtm = LBound(varColours)
    lngTop = UBound(varColours)
    For Each rngCell In ActiveSheet.UsedRange.Cells
        If (rngCell.Interior.Pattern <> -4142) Then
            For lngIndex = lngBtm To lngTop
                If rngCell.Interior.Color = varColours(lngIndex) Then
                    rngCell.Interior.Pattern = -4142
                    Exit For
                End If
            Next lngIndex
        End If
    Next rngCell
    '
    Application.ScreenUpdating = True
    '
End Sub

 

[gibson8]

Apologies - VBA isn't straight-forward when it comes to colors. Use this instead:

Sub RemoveSpecificHighlight()
    Dim rngCell As Range
    Dim varColours As Variant
    Dim lngIndex As Long
    Dim lngBtm As Long
    Dim lngTop As Long
    '
    Application.ScreenUpdating = False
    '
    varColours = Array(RGB(255, 50, 50), RGB(0, 230, 0), RGB(0, 204, 255), RGB(250, 250, 0), RGB(250, 0, 250), RGB(48, 150, 99), RGB(190, 190, 190), RGB(205, 205, 255))
    lngBtm = LBound(varColours)
    lngTop = UBound(varColours)
    For Each rngCell In ActiveSheet.UsedRange.Cells
        If (rngCell.Interior.Pattern <> -4142) Then
            For lngIndex = lngBtm To lngTop
                If rngCell.Interior.Color = varColours(lngIndex) Then
                    rngCell.Interior.Pattern = -4142
                    Exit For
                End If
            Next lngIndex
        End If
    Next rngCell
    '
    Application.ScreenUpdating = True
    '
End Sub

Thank you so much, @CephasOz
I don't understand the 4142 number, how do you get this number?
Please kindly elaborate a little more.
Thanks.

​

 

[CephasOz]

Sorry. You can replace both of the -4142s with xlNone, which makes it a lot easier to read.

 

[gibson8]

Thank you CephasOZ, you are a gentleman.