Hi
I dont know where to start on this one but let me explain.
I was given this macro to delete matching records from sheets 1 & 2. It seems to work good but the issue I seem to be having is when there is 2 entries exactly the same in sheets 1 and 2 its coming up pointing out that its a duplicate entry. This is supposed to be the case but when there is 1 entry in sheet 1 and then 2 entries in sheet 2 the same then this is a duplicated entry and needs marking up as duplicate.
Can this macro be amended to do that?
Posted here as well Macro shows duplicated entries but sometimes they are not duplicated due to data.
I dont know where to start on this one but let me explain.
I was given this macro to delete matching records from sheets 1 & 2. It seems to work good but the issue I seem to be having is when there is 2 entries exactly the same in sheets 1 and 2 its coming up pointing out that its a duplicate entry. This is supposed to be the case but when there is 1 entry in sheet 1 and then 2 entries in sheet 2 the same then this is a duplicated entry and needs marking up as duplicate.
Can this macro be amended to do that?
Code:
Option Explicit
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
Posted here as well Macro shows duplicated entries but sometimes they are not duplicated due to data.