Sub FindDupes()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim iRange As Range
Dim FinalRow As Long, FinalCol As Long
Dim FoundCount As Long
Application.ScreenUpdating = False
Set ws1 = Worksheets("Sheet1")
ws1.Activate
' Set up the criteria range
Set ws2 = Worksheets("Sheet2")
FinalRow = ws2.Cells(Rows.Count, 1).End(xlUp).Row
ws2.Cells(1, 1).Resize(FinalRow, 5).Name = "OutList"
' set up the input range
FinalRow = ws1.Cells(Rows.Count, 1).End(xlUp).Row
FinalCol = ws1.Cells(1, Columns.Count).End(xlToLeft).Column
Set iRange = ws1.Cells(1, 1).Resize(FinalRow, FinalCol)
' Find the items to Remove
iRange.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:= _
Range("OutList"), Unique:=False
FoundCount = iRange.Columns(1).SpecialCells(xlCellTypeVisible).Count - 1
If FoundCount = 0 Then
ws1.ShowAllData
MsgBox "No Duplicates Found."
Exit Sub
End If
ws1.Cells(2, 1).Resize(FinalRow - 1, 1).SpecialCells(xlCellTypeVisible).EntireRow.Interior.Color = vbYellow
ws1.ShowAllData
ws1.Cells(1, 1).Select
MsgBox FoundCount & " Duplicate Addresses Found."
Application.ScreenUpdating = True
End Sub