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

 

[Akuini]

Win 10, Excel 365 32 bit, AMD Ryzen 3 3200G, 8 GB RAM

 

[Marc L]

Thanks. The time gap between our setup seems a bit huge even if I met the same issue with several computers​

where with big data (more than 500K unique elements) using a Collection was faster than a Dictionary …​

 

[Marc L]

Little loop tweak :​

Sub Demo2a()
       Const A = 7, D = 4
         Dim Rg As Range, P&, V, W, N&
         Application.ScreenUpdating = False
    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 > 1 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 & "))")
        For N = P - 1 To 1 Step -1
            While V(P, 1) < -V(N, 1) And P < UBound(V):  P = P + 1:  Wend
            While V(P, 1) = -V(N, 1) And W(P, 1) < W(N, 1) And P < UBound(V):  P = P + 1:  Wend
            If V(P, 1) = -V(N, 1) Then If W(P, 1) = W(N, 1) Then V(N, 1) = Empty: V(P, 1) = Empty
            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
        Application.ScreenUpdating = True
End Sub

 

[Marc L]

​

Bad edit in my previous post :​

If P > 2 And P < .Count Then

 

[Marc L]

​

No in fact the good version is P > 1 so post #43 is OK …​

 

[ghrek]

Sorry forgot I had asked on we earlier thanks for link