How do I delete matching positive and negative entries in a column

[ghrek]

Hi

In column G of my workbook I have lots of positive and negative values. Im trying to get it to look all the way down column G and if there is a matching positive and negative entry of the same value I need the rows they are on completely deleting.

Any Ideas?

Thanks

 

[Marc L]

I have a difference of an amount and I’m trying to find out what makes that difference

Did you apply some sort to your link workbook or this is the state when you received the data ?​

 

[ghrek]

@ghrek
Try this:
The code sort the data by col D. If it's not ok then I can amend the code to sort it back to the initial order.
I use col H as temporary helper column.
The code took about 8 second to finish:

Sub positive_negative_match2()
'positive-negative match, GROUP
Dim i As Long, z As Long, a As Long
Dim va, vb, vc, m, s, t
Dim d As Object

t = Timer
Application.ScreenUpdating = False
With Range("A1").CurrentRegion
.Sort Key1:=.Cells(1, 4), Order1:=xlAscending, Header:=xlYes
End With
n = Range("D" & Rows.Count).End(xlUp).Row
va = Range("D1:D" & n)
vc = Range("G1:G" & n)
ReDim vb(1 To n, 1 To 1)

For i = 1 To n
    vb(i, 1) = "x" 'mark for NOT positive-negative match
Next
Set d = CreateObject("scripting.dictionary")

For i = 2 To n
d.RemoveAll
    Do
    z = vc(i, 1)
      
        If d.Exists(z) Then
            d(z) = d(z) & ":" & i
        ElseIf d.Exists(-z) Then
            s = Split(d(-z), ":")
            m = s(UBound(s))
            vb(i, 1) = "" 'mark for positive-negative match
            vb(m, 1) = "" 'mark for positive-negative match
                If UBound(s) = 0 Then
                    d.Remove -z
                    Else
                    d(-z) = Left(d(-z), Len(d(-z)) - Len(m) - 1)
                End If
        Else
            d(z) = i
        End If
        i = i + 1
        If i > UBound(va, 1) Then Exit Do
    Loop While va(i, 1) = va(i - 1, 1)
    i = i - 1

Next

Range("H1").Resize(n, 1) = vb
With Range("A1").CurrentRegion
    .Sort Key1:=.Cells(1, 8), Order1:=xlAscending, Header:=xlYes
    a = Range("H" & Rows.Count).End(xlUp).Row + 1
    Rows(a & ":" & n).Delete
    Range("H:H").Delete
End With
Application.ScreenUpdating = True

Debug.Print Timer - t
End Sub

If you want to check whether the code works correctly or not, you can comment this part:

'With Range("A1").CurrentRegion
'    .Sort Key1:=.Cells(1, 8), Order1:=xlAscending, Header:=xlYes
'    a = Range("H" & Rows.Count).End(xlUp).Row + 1
'    Rows(a & ":" & n).Delete
'    Range("H:H").Delete
'End With

then check col H, the blank cells in col H are the ones that have positive-negative match on the same date, so they are going to be deleted.

Done it with the formula using the extra bit on the bottom and got what I want.

Big thanks

 

[Marc L]

Question : compare only the date or the date and time ? 'Cause with the date only many rows match and can be deleted …​

 

[Akuini]

Question : compare only the date or the date and time ? 'Cause with the date only many rows match and can be deleted …

Good point Marc.

@ghrek
I thought the hours part in col D are the same in all cells, so my code in post #30 actually uses date+time as the criteria.
If the criteria is only the date then try this one instead:
I added this part to remove the time part on array va using INT function:
For i = 2 To UBound(va, 1)
va(i, 1) = Int(va(i, 1))
Next

Sub positive_negative_match3()
'positive-negative match, GROUP
Dim i As Long, z As Long, a As Long
Dim va, vb, vc, m, s, t
Dim d As Object

t = Timer
Application.ScreenUpdating = False
With Range("A1").CurrentRegion
.Sort Key1:=.Cells(1, 4), Order1:=xlAscending, Header:=xlYes
End With
n = Range("D" & Rows.Count).End(xlUp).Row
va = Range("D1:D" & n)

For i = 2 To UBound(va, 1)
    va(i, 1) = Int(va(i, 1))
Next

vc = Range("G1:G" & n)
ReDim vb(1 To n, 1 To 1)

For i = 1 To n
    vb(i, 1) = "x" 'mark for NOT positive-negative match
Next
Set d = CreateObject("scripting.dictionary")

For i = 2 To n
d.RemoveAll
    Do
    z = vc(i, 1)
       
        If d.Exists(z) Then
            d(z) = d(z) & ":" & i
        ElseIf d.Exists(-z) Then
            s = Split(d(-z), ":")
            m = s(UBound(s))
            vb(i, 1) = "" 'mark for positive-negative match
            vb(m, 1) = "" 'mark for positive-negative match
                If UBound(s) = 0 Then
                    d.Remove -z
                    Else
                    d(-z) = Left(d(-z), Len(d(-z)) - Len(m) - 1)
                End If
        Else
            d(z) = i
        End If
        i = i + 1
        If i > UBound(va, 1) Then Exit Do
    Loop While va(i, 1) = va(i - 1, 1)
    i = i - 1

Next

Range("H1").Resize(n, 1) = vb
With Range("A1").CurrentRegion
    .Sort Key1:=.Cells(1, 8), Order1:=xlAscending, Header:=xlYes
    a = Range("H" & Rows.Count).End(xlUp).Row + 1
    Rows(a & ":" & n).Delete
    Range("H:H").Delete
End With
Application.ScreenUpdating = True

Debug.Print Timer - t
End Sub

 

[Marc L]

I thought the hours part in col D are the same in all cells,

Yes 'cause I saw with my VBA arrays procedure I have less remaining rows than yours …​

​

Now your last version on my tests old laptop computer needs 33s for 161 401 remaining rows with the zeros​

versus my VBA Arrays Sort & Clear procedure without any Dictionary just takes 12s but for 165 406 remaining rows without any zero !​

There is a glitch somewhere but I can't see on which side …​

 

[Akuini]

Now your last version on my tests old laptop computer needs 33s for 161 401 remaining rows with the zerosversus my VBA Arrays Sort & Clear procedure without any Dictionary just takes 12s but for 165 406 remaining rows without any zero !There is a glitch somewhere but I can't see on which side …

Can you post your code?

 

[Akuini]

There is a glitch somewhere but I can't see on which side …

@ghrek & @Marc L
Turns out the problem was on my side. I forgot to change the z variable from Long to Double. Big mistake!!!??
I ran this revised code and the result is 173865 rows remaining, with zero. I then counted the zero, it is 8459. So without zeros it is 165406, same as your result.
Thanks Marc, for pointing out the problem that made me double check my code.

Sub positive_negative_match4()
'positive-negative match, GROUP
Dim i As Long, z As Double, a As Long
Dim va, vb, vc, m, s, t
Dim d As Object
Dim w As String

t = Timer
Application.ScreenUpdating = False
With Range("A1").CurrentRegion
.Sort Key1:=.Cells(1, 4), Order1:=xlAscending, Header:=xlYes
End With
n = Range("D" & Rows.Count).End(xlUp).Row
va = Range("D1:D" & n)

For i = 2 To UBound(va, 1)
    va(i, 1) = Int(va(i, 1))
Next

vc = Range("G1:G" & n)
ReDim vb(1 To n, 1 To 1)

For i = 1 To n
    vb(i, 1) = "x" 'mark for NOT positive-negative match
Next
Set d = CreateObject("scripting.dictionary")

For i = 2 To n
d.RemoveAll
    Do
    z = vc(i, 1)
      
        If d.Exists(z) Then
            d(z) = d(z) & ":" & i
        ElseIf d.Exists(-z) Then
            w = d(-z)
            s = Split(w, ":")
            m = s(UBound(s))
            vb(i, 1) = "" 'mark for positive-negative match
            vb(m, 1) = "" 'mark for positive-negative match
                If UBound(s) = 0 Then
                    d.Remove -z
                    Else
                    d(-z) = Left(w, Len(w) - Len(m) - 1)
                End If
        Else
            d(z) = i
        End If
        i = i + 1
        If i > n Then Exit Do
    Loop While va(i, 1) = va(i - 1, 1)
    i = i - 1

Next

Range("H1").Resize(n, 1) = vb
With Range("A1").CurrentRegion
    .Sort Key1:=.Cells(1, 8), Order1:=xlAscending, Header:=xlYes
    a = Range("H" & Rows.Count).End(xlUp).Row + 1
    Rows(a & ":" & n).Delete
    Range("H:H").Delete
End With
Application.ScreenUpdating = True

Debug.Print Timer - t
End Sub

 

[Marc L]

Can you post your code?

Required some time to be adapted from my old tools this is my Arrays Sort & Clear procedure :​

Sub Demo2()
       Const A = 7, D = 4
         Dim Rg As Range, P&, V, W, N&
    With Application
        .ScreenUpdating = False
        .StatusBar = "      Initialization …"
    With [A1].CurrentRegion.Rows
        .Sort .Cells(A), 1, .Cells(D), , 1, Header:=1
         Set Rg = .Columns(A).Find(0, , , 1)
    If Rg Is Nothing Then
        V = Application.Lookup(-0.00001, .Columns(A))
        If IsNumeric(V) Then P = .Columns(A).Find(V, , , 1, , 2).Row
    Else
          P = Rg(0).Row
       .Range(Rg, .Columns(A).Find(0, , , 1, , 2)).ClearContents
          Set Rg = Nothing
       .Sort .Cells(A), Header:=1
    End If
    If P > 2 And P < .Count Then
             .Item("2:" & P).Sort .Cells(A), 1, .Cells(D), , 2, Header:=2
        With .Range(.Cells(2, A), .Cells(A).End(xlDown))
            V = .Value2
            W = Evaluate("IF({1},INT(" & .Columns(D - A + 1).Address & "))")
            Application.StatusBar = "      Checking in progress …"
        For N = P - 1 To 1 Step -1
            While V(P, 1) < -V(N, 1) And P < UBound(V):  P = P + 1:  Wend
        If V(P, 1) = -V(N, 1) Then
            Do While W(P, 1) < W(N, 1) And P < UBound(V)
                P = P + 1:  If V(P, 1) > -V(N, 1) Then Exit Do
            Loop
                If V(P, 1) = -V(N, 1) Then If W(P, 1) = W(N, 1) Then V(N, 1) = Empty: V(P, 1) = Empty
        End If
            If P = UBound(V) Then If V(P, 1) < -V(N, 1) Then Exit For
        Next
           .Value2 = V
        End With
    End If
    If .Cells(A).End(xlDown).Row < .Count Then
       .Sort .Cells(A), Header:=1
       .Item(Cells(Rows.Count, A).End(xlUp)(2).Row & ":" & .Count).Clear
    End If
       .Sort .Cells(D), Header:=1
    End With
        .ScreenUpdating = True
        .StatusBar = False
    End With
End Sub

​

The last Sort codeline is optional …​

 

[Akuini]

Required some time to be adapted from my old tools this my procedure Arrays Sort & Clear :

Thanks Marc, I tested your code, it took 9.77 seconds while my last code took 13.74 seconds. Great code.

 

[Marc L]

​

Thanks ! Excel 32 or 64 bits ? Processor ?​

​

As I can't see on my tests laptop under xL 2010 32 bits / W8.1 and i3 2.2GHz why Dictionary is so slow …​

​

I just ran your v4 : 30s …​