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]

Really sorry I think im confusing myself more as I go on. Lets start again

On sheet 1 there is data that I have downloaded and sheet 2 is data that has been input manually.

I need to compare the data in sheet 1 against sheet 2 and where data is in sheet 1 but not sheet 2 I need it marked as missing on sheet 1
Where is there is data in sheet 1 and sheet 2 I need both entries from the sheets deleting.
Where there is one entry on sheet 1 but 2 entries on sheet 2 I need the entry on sheet 1 and one of them deleting from sheet 2 leaving the other one there as sheet 2 is obviously duplicated..

There may be occasions where there are 2 entries on sheets 1 & 2 the same and thats OK.

Is that better?

 

[Fluff]

Can you tell me where on sheet 2 there are duplicate entries where not all should be deleted.

 

[ghrek]

Sorry im confused there.

On sheet 2 if there are 2 entries the same but only 1 entry on sheet 1 thats when 1 entry from sheet 2 needs deleting and one remaining as its duplicated, BUT if there are 2 entries the same on sheets 1 & 2 then they are not duplicated.

Does that make sense?

 

[Fluff]

Yes it makes perfect sense, but I need you to point out some of those situations, as I can't find any.

 

[ghrek]

Right I added something to the workbook in the link below

You see the data in sheet 1 row 11 and sheet 2 rows 9 and 24 they are duplicated in sheet 2. In that instance I need one of them deleted and other kept.

PERIOD END ISSING SHIFTS THURS.xlsb

 

[Fluff]

Does this highlight the correct rows for deletion on both sheets?

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(dict1.Item(Txt)(0))
        Else
            Set delRng1 = Union(delRng1, ws1.Rows(dict1.Item(Txt)(0)))
        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) = 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
If Not delRng1 Is Nothing Then delRng1.Interior.Color = 45678
If Not delRng2 Is Nothing Then delRng2.Interior.Color = 45678
End Sub

 

[ghrek]

Yes thats correct just need them to delete so it leaves the duplicated and missing ones

 

[Fluff]

In that case just change the two delRng to .Delete

 

[ghrek]

Ok you mean just here...

If Not delRng1 Is Nothing Then delRng1.Interior.Color = 45678
If Not delRng2 Is Nothing Then delRng2.Interior.Color = 45678

 

[Fluff]

That's right, instead of applying a colour just change them to delete the range.