• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

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

Marc L

Excel Ninja
Down to 36 with this ultimate demonstration to paste to the top of a module :​
Code:
Dim D%(), V, E&

Sub ZSum(ByVal S@, ByVal R&, C%)
           Dim Z@
    For R = R To E
        If V(R, 1) Then
               Z = S + V(R, 1)
            If Z = 0 Then
               C = 1:  D(R, 0) = 1: V(R, 1) = 0: Exit For
            ElseIf Sgn(Z) = Sgn(S) Then
                ZSum Z, R + 1, C
                If C Then D(R, 0) = 1: V(R, 1) = 0: Exit For
            End If
        End If
    Next
End Sub

Sub Demo1r2d2()
        Dim R&, L&, S@, T&, W, C%
        Application.ScreenUpdating = False
    With Sheet1.[A1].CurrentRegion.Columns
      ReDim D(1 To .Rows.Count, 0)
        For R = 2 To .Rows.Count
            L = R
            S = .Cells(R, 5)
            While .Cells(L + 1, 1) = .Cells(R, 1):  L = L + 1:  S = S + .Cells(L, 5):  Wend
            If S = 0 Then For T = R To L: D(T, 0) = 1: Next
            R = L
        Next
            S = Application.Sum(D)
            If S Then .Item(.Count + 1) = D: .Resize(, .Count + 1).Sort .Item(.Count + 1), 1, Header:=1
            T = .Rows.Count - S
            ReDim D(1 To T, 0)
            V = .Item(5).Resize(T)
        For R = 2 To T
            If V(R, 1) Then
                W = Application.Match(-V(R, 1), V, 0)
                If IsNumeric(W) Then V(R, 1) = 0: V(W, 1) = 0
            End If
                If V(R, 1) = 0 Then D(R, 0) = 1
        Next
            S = Application.Sum(D)
            If S Then With .Resize(T, .Count + 1): .Item(.Count) = D: .Sort .Item(.Count), 1, Header:=1: End With
            T = T - S
            ReDim D(1 To T, 0)
            V = .Item(5).Resize(T)
        For R = 2 To T
            If V(R, 1) > 0 Then
                    S = V(R, 1)
                    W = R
                For L = 2 To T
                    If V(L, 1) < 0 Then
                        S = S + V(L, 1):  If S < 0 Then Exit For
                        W = W & " " & L
                        If S = 0 Then For Each W In Split(W): D(W, 0) = 1: V(W, 1) = 0: Next: Exit For
                    End If
                Next
            End If
        Next
        For R = 2 To T
            If V(R, 1) < 0 Then
                    S = V(R, 1)
                    W = R
                For L = 2 To T
                    If V(L, 1) > 0 Then
                        S = S + V(L, 1):  If S > 0 Then Exit For
                        W = W & " " & L
                        If S = 0 Then For Each W In Split(W): D(W, 0) = 1: V(W, 1) = 0: Next: Exit For
                    End If
                Next
            End If
        Next
            S = Application.Sum(D)
            If S Then With .Resize(T, .Count + 1): .Item(.Count) = D: .Sort .Item(.Count), 1, Header:=1: End With
            T = T - S
            S = 0
        If T > 3 Then
            With .Resize(T, .Count + 1)
                 .Sort .Item(5), 1, Header:=1
                  V = .Item(5)
                  W = Application.Lookup(-0.00001, V)
                If IsNumeric(W) Then
                       L = .Item(5).Find(W, , , 1, , 2).Row
                    If L < T Then
                        ReDim D(1 To T, 0)
                        E = T
                    For R = 2 To L
                        ZSum V(R, 1), L + 1, C
                        If C Then D(R, 0) = 1: V(R, 1) = 0: C = 0
                    Next
                        E = L
                    For R = L + 1 To T
                        If V(R, 1) Then
                            ZSum V(R, 1), 2, C
                            If C Then D(R, 0) = 1: V(R, 1) = 0: C = 0
                        End If
                    Next
                        S = Application.Sum(D)
                        If S Then .Item(.Count) = D: .Sort .Item(.Count), Header:=1
                    End If
                End If
                   .Resize(T - S).Sort .Cells(1), Header:=1
            End With
        End If
           .Item(.Count + 1).Clear
           T = T - S + 1
        If T <= .Rows.Count Then
            .Rows(T & ":" & .Rows.Count).Clear
            .Item(6).Rows("2:" & T - 2).ClearContents
            .Cells(T - 1, 6) = Application.Sum(.Item(5))
        End If
    End With
        Application.ScreenUpdating = True
        Erase D, V
End Sub
You may Like it !​
 

shili12

Member
Yes the above is the final solution (for the want of a better word/phrase)
It actually closely matches the one I did manually deleting those which were not exact (integers) after you gave your 1st VBA code.
Thank you.
@vletm refer to post #9 & #10, it actually happened and was beyond my expectation
 

Attachments

Last edited:

Marc L

Excel Ninja
As they are different combinations to get the same remaining total …​
Read the Important note to readers introduction I wrote two years ago in this thread :​
 

shili12

Member
Exactly, you're absolutely right on #28, I'm now trying your VBA out on a different worksheet now and even still this minor decimals are getting in the way,
So a visual inspection is necessary.

79224
 

Marc L

Excel Ninja
According to accountancy / financial rules a cent is not peanut !​
Once I was asked to operate with truncating the decimals - so breaking the rules ! - but​
when the data does not have any reference the automatic reconciliation is just a lottery so could never win …​
 
Top