Hi
I have the following macro that looks between sheets 1 & 2 and deletes all matching entries and then marks all missing entries.
Im trying to add to it so that it again looks through all the workbook but also highlights duplicated entries.
Dont know where to start and didnt know if anyone had any ideas?
I have the following macro that looks between sheets 1 & 2 and deletes all matching entries and then marks all missing entries.
Im trying to add to it so that it again looks through all the workbook but also highlights duplicated entries.
Dont know where to start and didnt know if anyone had any ideas?
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
Last edited by a moderator: