Hi
brings
I had this macro that points out duplicate and missing items. It brings up the missing on sheet 1 but for some reason does not delete 1 duplicated entry on sheet 2 and then mark other as DUPLICATE in column E.
Any Ideas?
brings
I had this macro that points out duplicate and missing items. It brings up the missing on sheet 1 but for some reason does not delete 1 duplicated entry on sheet 2 and then mark other as DUPLICATE in column E.
Any Ideas?
VBA Code:
Sub DeleteIdenticalRecordsFromTwoSheets()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim lr1 As Long, lr2 As Long, i As Long
Dim x, y, dict1 As Object, dict2 As Object
Dim delRng1 As Range, delRng2 As Range
Dim Txt As String
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
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)
Txt = x(i, 1) & x(i, 2) & x(i, 3) & x(i, 4)
If Not dict1.exists(Txt) Then
dict1.Add Txt, Array(i, 1)
Else
dict1(Txt) = Array(dict1(Txt)(0), dict1(Txt)(1) + 1)
End If
Next i
For i = 1 To UBound(y, 1)
Txt = y(i, 1) & y(i, 2) & y(i, 3) & y(i, 4)
If Not dict2.exists(Txt) Then dict2.Add Txt, i
Next i
For i = 1 To UBound(x, 1)
Txt = x(i, 1) & x(i, 2) & x(i, 3) & x(i, 4)
If dict2.exists(Txt) Then
If delRng1 Is Nothing Then
Set delRng1 = ws1.Rows(i)
Else
Set delRng1 = Union(delRng1, ws1.Rows(i))
End If
Else
ws1.Range("E" & i) = "Missing"
End If
Next i
For i = 1 To UBound(y, 1)
Txt = y(i, 1) & y(i, 2) & y(i, 3) & y(i, 4)
If dict1.exists(Txt) Then
If dict1(Txt)(1) = 0 Then
ws2.Cells(i, 5) = "Duplicate"
Else
dict1(Txt) = Array(dict1(Txt)(0), dict1(Txt)(1) - 1)
If delRng2 Is Nothing Then
Set delRng2 = ws2.Rows(i)
Else
Set delRng2 = Union(delRng2, ws2.Rows(i))
End If
End If
End If
Next i
If Not delRng1 Is Nothing Then delRng1.Delete
If Not delRng2 Is Nothing Then delRng2.Delete
End Sub