Sub DeleteIdenticalRecordsFromTwoSheets()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim lr1 As Long, lr2 As Long, i As Long
Dim x, y, xx(), yy(), dict1, dict2
Dim delRng1 As Range, delRng2 As Range
Application.ScreenUpdating = False
Set ws1 = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")
lr1 = ws1.Cells(Rows.Count, 1).End(xlUp).Row
lr2 = ws2.Cells(Rows.Count, 1).End(xlUp).Row
ws1.Range("A1:D" & lr1).RemoveDuplicates Columns:=Array(1, 2, 3, 4), Header:=xlNo
lr1 = ws1.Cells(Rows.Count, 1).End(xlUp).Row
x = ws1.Range("A1:D" & lr1).Value
y = ws2.Range("A1:D" & lr2).Value
Set dict1 = CreateObject("Scripting.Dictionary")
Set dict2 = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(x, 1)
dict1.Item(x(i, 1) & x(i, 2) & x(i, 3) & x(i, 4)) = ws1.Range("A" & i).Address
Next i
For i = 1 To UBound(y, 1)
dict2.Item(y(i, 1) & y(i, 2) & y(i, 3) & y(i, 4)) = ws2.Range("A" & i).Address
Next i
ws1.Columns("E").Clear
ws2.Columns("E").Clear
For i = 1 To UBound(x, 1)
If dict2.exists(x(i, 1) & x(i, 2) & x(i, 3) & x(i, 4)) Then
If delRng1 Is Nothing Then
Set delRng1 = ws1.Range(dict1.Item(x(i, 1) & x(i, 2) & x(i, 3) & x(i, 4)))
Else
Set delRng1 = Union(delRng1, ws1.Range(dict1.Item(x(i, 1) & x(i, 2) & x(i, 3) & x(i, 4))))
End If
Else
ws1.Cells(i, 5) = "Missing"
End If
Next i
For i = 1 To UBound(y, 1)
If dict1.exists(y(i, 1) & y(i, 2) & y(i, 3) & y(i, 4)) Then
If delRng2 Is Nothing Then
Set delRng2 = ws2.Range(dict2.Item(y(i, 1) & y(i, 2) & y(i, 3) & y(i, 4)))
Else
Set delRng2 = Union(delRng2, ws2.Range(dict2.Item(y(i, 1) & y(i, 2) & y(i, 3) & y(i, 4))))
End If
End If
Next i
If Not delRng1 Is Nothing Then delRng1.EntireRow.Delete
If Not delRng2 Is Nothing Then delRng2.EntireRow.Delete
lr2 = ws2.Cells(Rows.Count, 1).End(xlUp).Row
y = ws2.Range("A1:D" & lr2).Value
For i = 1 To UBound(y, 1)
If dict1.exists(y(i, 1) & y(i, 2) & y(i, 3) & y(i, 4)) Then
ws2.Range("E" & i).Value = "Duplicate"
End If
Next i
Application.ScreenUpdating = True
End Sub
Bookmarks