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]

Im 99% there

Just a few tweets in duplication. In sheet 1 there are 2 entries and also 2 in sheet 2. This I need them both deleted on both sheets as they are not duplicates as there are 2 entries on sheet 1 but if there was only 1 entry on sheet 1 but 2 on sheet 2 I need these marked as duplicate.

At present its deleting both entries on sheet 1 and only 1 entry on sheet 2.

 

[Fluff]

At present its deleting both entries on sheet 1 and only 1 entry on sheet 2.

Not for me it doesn't.

 

[ghrek]

Sorry what I meant was if on sheet 1 there are 2 entries the same and there are 2 entries the same on sheet 2 then I need both entries on sheet 2 deleting BUT if only 1 entry on sheet 1 and 2 on sheet 2 then yes I need one marking up as duplicate.

I just cant get it to do that. Are you using the workbook I posted on here?

 

[Fluff]

This will mark the duplicates.

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

 

[ghrek]

Was I right to replace that in the area of the macro you originally had the text as in getting run time error 13 type mismatch at the following point
If dict1(Txt)(1) = 0 Then

 

[Fluff]

It replaces this part of the previous code

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) = 1 Then
         dict1.Remove Txt
      Else
         dict1(Txt) = Array(dict1(Txt)(0), dict1(Txt)(1) - 1)
      End If
      If delRng2 Is Nothing Then
         Set delRng2 = ws2.Rows(i)
      Else
         Set delRng2 = Union(delRng2, ws2.Rows(i))
      End If
   End If
Next i

 

[ghrek]

Right OK it seems to of gone the other way now. Its deleting 2 entries on sheet 2 if there are 2 on sheet 1 but its only deleting 1 entry on sheet 1

Its marking up duplicate OK. If you look at this workbook with amendment to macro in I need lines 1 & 2 deleting from sheets 1 & 2 as they are both matching and 1 entry of line 3 left on sheet 2 and marked as duplicate. To me at the moment its deleting both entries starting 1234 from sheet 2 but only 1 from sheet 1

Hope that helps

PERIOD END ISSING SHIFTS THURS (1).xlsb

 

[Fluff]

Nothing has changed regards deleting rows in sheet1, so if it worked before it should still work now.

 

[ghrek]

Thats what I thought but it defentally not. In that link I put on earlier it leaves 1 entry in sheet 1

 

[Fluff]

Ok, how about

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