Can I add to macro so it deletes a positive and negative figure for same amount

[ghrek]

Hi

I have this macro that deletes matching records but need to add to it. What im trying to do is look in sheet 2 and if columns A,B,C are and exact match and then column D has a matching positive and negative figure I need that deleting too.

What I mean is lets say row 10 is 1256 159 22/01/20 10.00 and row 150 is 1256 159 22/01/20 -10.00 I need the 2 rows deleting. Is that possible?

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

 

[jkicker]

if there are no negatives in columns A,B or C, change
y = ws2.Range("A1:D" & lr2).Value
to
y = abs(ws2.Range("A1:D" & lr2).Value)

i don't know anything about dictionaries so i can't be of better help.

maybe change:
dict1.Item(x(i, 1) & x(i, 2) & x(i, 3) & x(i, 4)) = ws1.Range("A" & i).Address

dict2.Item(y(i, 1) & y(i, 2) & y(i, 3) & y(i, 4)) = ws2.Range("A" & i).Address

to:
dict1.Item(x(i, 1) & x(i, 2) & x(i, 3) & abs(x(i, 4))) = ws1.Range("A" & i).Address

dict2.Item(y(i, 1) & y(i, 2) & y(i, 3) & abs(y(i, 4))) = ws2.Range("A" & i).Address

? good luck