Macro I was given dont seem to be doing what it originally supposed to do.

[ghrek]

Hi

I was given this macro and it dont seem to be doing what I want it to do anymore. What im trying to do is compare data in sheets 1 &2 and if matching entries I need them deleting from both sheets.

It should then mark on sheet 1 missing or sheet 2 duplicate if it is the case.

It seems to do it for some cells but others doing nothing, Could someone possibly have a look and advise as dont know where to start.

Big thanks in advance

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

 

[ghrek]

BINGO SPOT ON

Big big thanks fluff and I appreciate your patience .

 

[Fluff]

Glad to help & thanks for the feedback.