Macro pointing out duplicated entries when not duplicated

[ghrek]

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?

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.

 

[Worf]

Please confirm your logic by stating if the following cases are duplicates or not. We also need to know what pairs of data form the duplicates for the questions below.

The other thread didn’t help me much.

• The entry appears once on each sheet.
• The entry appears twice on sheet 1.
• The entry appears twice on each sheet.
• The entry appears once on sheet 1 and twice on sheet 2.

 

[ghrek]

Sorry what I meant was

• The entry appears once on each sheet. It is NOT a duplicate and needs deleting
• The entry appears twice on each sheet. it is NOT a duplicate and needs deleting
• The entry appears once on sheet 1 and twice on sheet 2. THIS IS a duplicate and needs to remain on sheet 2 and show up as "DUPLICATE"

Hope that helps

 

[Worf]

All right, I will work on it as soon as possible…

 

[Worf]

Please answer the questions below:

• The entry appears once on each sheet. It is NOT a duplicate and needs deleting. Should we delete both items?
• The entry appears twice on each sheet. It is NOT a duplicate and needs deleting. Should we delete all four items?
• The entry appears once on sheet 1 and twice on sheet 2. THIS IS a duplicate and needs to remain on sheet 2 and show up as "DUPLICATE". Which of the three items should be deleted?

 

[ghrek]

• The entry appears once on each sheet. It is NOT a duplicate and needs deleting. Should we delete both items? YES
• 
  
• The entry appears twice on each sheet. It is NOT a duplicate and needs deleting. Should we delete all four items? YES
• 
  
• The entry appears once on sheet 1 and twice on sheet 2. THIS IS a duplicate and needs to remain on sheet 2 and show up as "DUPLICATE". Which of the three items should be deleted? THE ENTRY ON SHEET 1 AND 1 ENTRY ON SHEET 2.

Hope that helps.

 

[Worf]

This is a preliminary version:

Sub ghrek()
Dim first As Worksheet, sec As Worksheet, LRf%, i%
Set first = Sheets("shops")
Set sec = Sheets("sheet4")
LRf = first.Range("a" & Rows.count).End(xlUp).Row
'first.Range("b1:b" & LRf).Formula = _
'"=VLOOKUP(A1,INDIRECT(""sheet4!$a$1:$a$" & LR & """),1,FALSE)"
first.Range("b1:b" & LRf).Formula = _
"=MATCH(a1,sheet4!$A$1:$A$" & sec.Range("a" & Rows.count).End(xlUp).Row & ",0)"
For i = 1 To LRf
    If Not WorksheetFunction.IsNA(first.Cells(i, 2)) Then
        sec.Cells(first.Cells(i, 2), 1) = ""            ' delete from second sheet
        first.Cells(i, 1) = ""                          ' delete from first sheet
    End If
Next
End Sub

 

[Worf]

The code above performs the three tasks mentioned at post #6.

Do you want to flag the remaining item for the third case?