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

[Marc L]

Down to 36 with this ultimate demonstration to paste to the top of a module :​

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]

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

 

[Marc L]

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 :​

Knock off Single amounts against multiple amount (Similar and dissimilar) [SOLVED]

I need a formula to knock off a single amount against multiple amounts so that they net to zero. The amounts are usually netted off against multiple similar amounts for eg. 55,000 against 5 amounts of 11,000 . However they might also be cases where dissimilar amounts might net to zero. Please...

www.excelforum.com

 

[shili12]

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.

 

[Marc L]

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 …​

​