Color cells in a Range if it matches strings in array found in another range

[DeonM]

I have the following code that basically works fine. The purpose is to highlight any cells in the "Lookup" sheet that match any of the strings found in the specified range in the "Fails" sheet.

The problem is that this method won't highlight a second or third etc. occurrence of the string in the Lookup sheet. My logic tells me I should loop through the "Lookup" range and compare to the values in the "Fails" array. I've tried lots of different loops, but can't get it to work.

Any help please!!!

        Dim myArray As Variant, word As Variant
        Dim LastSrcRow As Long, LastDestRow As Long
        
        LastSrcRow = Worksheets("Fails").Range("A65536").End(xlUp).row
        LastDestRow = Worksheets("Lookup").Range("A65536").End(xlUp).row
                
        myArray = Worksheets("Fails").Range("T2:T" & LastSrcRow).Value
                  
        For Each word In myArray
            Worksheets("Lookup").Range("E2:F" & LastDestRow).Find(word).Interior.ColorIndex = 22
        Next word

 

[mumps]

Try:

Sub Test()
    Application.ScreenUpdating = False
    Dim LastSrcRow As Long, word As Range, sAddr As String, fnd As Range
    LastSrcRow = Sheets("Fails").Range("A" & Rows.Count).End(xlUp).Row
    For Each word In Sheets("Fails").Range("T2:T" & LastSrcRow)
        Set fnd = Sheets("Lookup").Range("E:F").Find(word, LookIn:=xlValues, lookat:=xlWhole)
        If Not fnd Is Nothing Then
            sAddr = fnd.Address
            Do
                fnd.Interior.ColorIndex = 22
                Set fnd = Sheets("Lookup").Range("E:F").FindNext(fnd)
            Loop While fnd.Address <> sAddr
            sAddr = ""
        End If
    Next word
    Application.ScreenUpdating = True
End Sub

 

[DeonM]

Try:

Sub Test()
    Application.ScreenUpdating = False
    Dim LastSrcRow As Long, word As Range, sAddr As String, fnd As Range
    LastSrcRow = Sheets("Fails").Range("A" & Rows.Count).End(xlUp).Row
    For Each word In Sheets("Fails").Range("T2:T" & LastSrcRow)
        Set fnd = Sheets("Lookup").Range("E:F").Find(word, LookIn:=xlValues, lookat:=xlWhole)
        If Not fnd Is Nothing Then
            sAddr = fnd.Address
            Do
                fnd.Interior.ColorIndex = 22
                Set fnd = Sheets("Lookup").Range("E:F").FindNext(fnd)
            Loop While fnd.Address <> sAddr
            sAddr = ""
        End If
    Next word
    Application.ScreenUpdating = True
End Sub

Thanks. That goes into a minutes long loop and eventually gives me a "Run time error 91. Object variable or With block variable not set" on "Loop While fnd.Address <> sAddr".

It also just highlights all blank cells in columns E:F and nothing of the values found in the Fails range.

 

[DeonM]

Sorry. Update to previous.

1. It seems the very long run time is caused by me having blank cells/values in the Fails range - therefore it finds all blanks in the Lookup Range as matches. I can solve that by cleaning the Fails range first of blank cells, but in your code, can one set it to ignore blank cells in the Fails range?
2. I also changed it a bit to define fnd Range as only including the used rows instead of entire columns.

Dim LastSrcRow As Long, word As Range, sAddr As String, fnd As Range, LastDestRow As Long
LastSrcRow = Sheets("Fails").Range("A65536").End(xlUp).row
LastDestRow = Worksheets("Lookup").Range("A65536").End(xlUp).row
For Each word In Sheets("Fails").Range("T2:T" & LastSrcRow)
Set fnd = Sheets("Lookup").Range("E2:F" & LastDestRow).Find(word, LookIn:=xlValues, lookat:=xlWhole)
If Not fnd Is Nothing Then
sAddr = fnd.Address
Do
fnd.Interior.ColorIndex = 22
Set fnd = Sheets("Lookup").Range("E2:F" & LastDestRow).FindNext(fnd)
Loop While fnd.Address <> sAddr
sAddr = ""
End If
Next word

 

[mumps]

This should take care of the blanks issue without you having to clean the Fails range of blank cells.

Sub Test()
    Dim LastSrcRow As Long, word As Range, sAddr As String, fnd As Range, LastDestRow As Long
    LastSrcRow = Sheets("Fails").Range("A65536").End(xlUp).Row
    LastDestRow = Worksheets("Lookup").Range("A65536").End(xlUp).Row
    For Each word In Sheets("Fails").Range("T2:T" & LastSrcRow)
        If word <> "" Then
            Set fnd = Sheets("Lookup").Range("E2:F" & LastDestRow).Find(word, LookIn:=xlValues, lookat:=xlWhole)
            If Not fnd Is Nothing Then
                sAddr = fnd.Address
                Do
                    fnd.Interior.ColorIndex = 22
                    Set fnd = Sheets("Lookup").Range("E2:F" & LastDestRow).FindNext(fnd)
                Loop While fnd.Address <> sAddr
                sAddr = ""
            End If
        End If
    Next word
End Sub

 

[DeonM]

Thanks for the help. That does it.

 

[mumps]

You are very welcome.