T4325_Compare Two Tables Extract Matching Items

https://excel-egy.com/forum/t4325
---------------------------------

Sub Compare_Two_Tables_Extract_Matching_Items()
    Dim x, ws As Worksheet, sh As Worksheet, r As Long

    Application.ScreenUpdating = False
        Set ws = ThisWorkbook.Worksheets(2)
        Set sh = ThisWorkbook.Worksheets(1)

        With sh.Range("A2:D" & sh.Cells(Rows.Count, 1).End(xlUp).Row)
            .Interior.Color = xlNone
            .Columns(4).ClearContents
        End With

        For r = 2 To ws.Cells(Rows.Count, 2).End(xlUp).Row
            x = Application.Match(ws.Cells(r, 1).Value, sh.Columns(1), 0)

            If Not IsError(x) Then
                sh.Cells(x, 4).Value = ws.Cells(r, 3).Value
                sh.Cells(x, 1).Resize(1, 4).Interior.Color = vbCyan
            End If
        Next r
    Application.ScreenUpdating = True
End Sub