Highlight rows in a sheet which contains a series of values in a column from another sheet

Question

I have 2 sheets in a workbook. Sheet 1 contains a list of numbers like,

A	B
9154	AAAA
9567	BBBB
9367	CCCC
9867	DDDD
9597	DDDD

In Sheet 2, I need to highlight all rows that contain values in Column A of sheet 1. Both sheet have more than 10,000 rows. So its not possible to input search value as a string.

i found a code like this to highlight a specific value from https://stackoverflow.com/a/27237420/478884. But how can i ask the code to search and highlight from Column A of sheet 1.

Sub foo()
    Dim value As String: value = "/"
    Dim rSearch As Range
    Dim firstFound As Range
    Dim nextFound As Range
    Dim wks As Worksheet

    For Each wks In Worksheets
        wks.Activate

        Set rSearch = Range("a1", Cells(Rows.Count, "a").End(xlUp))
        Set firstFound = rSearch.Find(value)
        If Not firstFound Is Nothing Then
            Set nextFound = firstFound
            Do
                nextFound.EntireRow.Interior.Color = RGB(1, 256, 1)
                Set nextFound = rSearch.FindNext(nextFound)
            Loop While nextFound.Address <> firstFound.Address
        End If
    Next
End Sub

Answer 1

Highlight Data Rows

• It is assumed that both ranges are 'nice' tables starting in cell A1 with one row of headers.
• Adjust the worksheet names, columns, and color in the constants section.

Option Explicit

Sub HighlightData()
    Const ProcName As String = "HighlightData"
    On Error GoTo ClearError
     
    ' Source
    Const sName As String = "Sheet1"
    Const sCol As Long = 1
    ' Destination
    Const dName As String = "Sheet2"
    Const dCol As Long = 1
    Const dColor As Long = vbGreen
    ' Workbook
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim ws As Worksheet
    Dim rg As Range, drg As Range
    Dim Data As Variant
    
    Application.ScreenUpdating = True
    
    ' Source
    
    Set ws = wb.Worksheets(sName)
    If ws.FilterMode Then ws.ShowAllData
    Set rg = ws.Range("A1").CurrentRegion
    Set drg = rg.Columns(sCol).Resize(rg.Rows.Count - 1).Offset(1)
    
    Data = drg.Value
    
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare
    
    Dim Key As Variant
    Dim r As Long
    
    For r = 1 To drg.Rows.Count
        Key = Data(r, 1)
        If Not IsError(Key) Then
            If Len(Key) > 0 Then
                dict(Key) = Empty
            End If
        End If
    Next r
    
    ' Either...
    r = 0
    ReDim Data(1 To dict.Count) As String
    For Each Key In dict.Keys
        r = r + 1
        Data(r) = Key
    Next Key
    ' ... or:
    'Data = Split(Join(dict.Keys, vbLf), vbLf) ' not sure what can all go wrong
    Set dict = Nothing
    
    ' Destination
     
    Set ws = wb.Worksheets(dName)
    If ws.FilterMode Then ws.ShowAllData
    Set rg = ws.Range("A1").CurrentRegion
    Set drg = rg.Resize(rg.Rows.Count - 1).Offset(1)
    drg.Interior.Color = xlNone
    
    rg.AutoFilter dCol, Data, xlFilterValues
    Erase Data
    Set rg = Nothing
    
    On Error Resume Next
        Set rg = drg.SpecialCells(xlCellTypeVisible)
    On Error GoTo ClearError
    ws.AutoFilterMode = False
    
    Dim IsSuccess As Boolean
    
    If Not rg Is Nothing Then rg.Interior.Color = dColor: IsSuccess = True
    
    Application.ScreenUpdating = True
    
    If IsSuccess Then MsgBox "Data highlighted.", vbInformation
    
ProcExit:
    Exit Sub
ClearError:
    Debug.Print "'" & ProcName & "' Run-time error '" _
        & Err.Number & "':" & vbLf & "    " & Err.Description
    Resume ProcExit
End Sub