How to determine what invoice numbers total to 0

Solution 1:

I have updated but not perfected the code, if the poster is still interested and would like to clarify if this outcome will work for them I will finish things off. As mentioned previously, This link: https://thedailycpa.com/identifying-excel-entries-that-add-up-to-a-specific-value/

has the solution for the individual IDs, then: https://stackoverflow.com/questions/41643134/vba-sub-not-defined-for-solver and https://stackoverflow.com/questions/15498429/loop-with-solver-vba

start to point toward the VBA solution.

Once you have activated the solver addon as outlined in the first link (it comes natively with excel so does not need to be downloaded) you can run the code as follows in a module:

   Sub SolverMacro(Add1 As String, Jval As Long)

Dim ws1 As Worksheet: Set ws1 = Sheet1
Dim ws2 As Worksheet: Set ws2 = Sheet2
Dim MyStr As String, MyCol As Long
Dim c As Range
mycount = 1

Do While ws2.Range("H4") > 1 And mycount < 5

    'Solver section
    '--------------------
        SolverReset
        SolverOk SetCell:="$H$3", MaxMinVal:=3, ValueOf:=0, ByChange:=Add1, _
            Engine:=2, EngineDesc:="Simplex LP"
        SolverAdd CellRef:=Add1, Relation:=5, FormulaText:="binary"
        SolverAdd CellRef:="$H$4", Relation:=3, FormulaText:="1"
        SolverSolve userfinish:=True
        SolverFinish KeepFinal:=1 ', ReportArray:=Array(1)
     '--------------------
    'Loop identifies all invoices found in this solve and copies to a string then deletes the row
        MyStr = "Total to 0: "
        For i = Range(Add1).Cells.Count + 1 To 2 Step -1
            If ws2.Range("D" & i) = 0 Then
                ws2.Range("D" & i) = 1
                GoTo MyNxti
            Else
                MyStr = Trim(MyStr & " " & ws2.Range("B" & i) & ", ")
                ws2.Range("A" & i).Resize(1, 5).Delete xlUp
            End If
MyNxti:
        Next i
    ' ---------------------------
        MyCol = ws2.Cells(Jval, Columns.Count).End(xlToLeft).Column + 1 'identifies last used row.
        If Trim(MyStr) = "Total to 0:" Then GoTo MyExitLoop
        ws2.Cells(Jval, MyCol) = Trim(MyStr)                                  'pastes string containing invoices that have added to zero
        Add1 = "D2:D" & ws2.Range("D2").CurrentRegion.Rows.Count + 1
        mycount = mycount + 1
Loop
MyExitLoop:
        Add1 = "D2:D" & ws2.Range("D2").CurrentRegion.Rows.Count + 1
        MyStr = "Outstanding: "
        For Each c In ws2.Range(Add1)
                MyStr = MyStr & ws2.Range("B" & c.Row) & ", "
                ws2.Range("A" & c.Row).Resize(1, 5).Clear
        Next c
        MyCol = ws2.Cells(Jval, Columns.Count).End(xlToLeft).Column + 1 'identifies last used row.
        ws2.Cells(Jval, MyCol) = MyStr                                  'pastes string containing invoices that have not added to zero
        MyStr = vbNullString
End Sub
Sub ExtractorSub()
mystart = Time
Application.ScreenUpdating = False
'Declare variables
'---------------------------------------
Dim ws1 As Worksheet: Set ws1 = Sheet1
Dim ws2 As Worksheet: Set ws2 = Sheet2
Dim MyUniqueArr, MyFullArr
Dim x As Long, y As Long, MyRW As Long, Add1 As String, Add2 As String
ws2.Range("G1") = "Target"
ws2.Range("H1") = 0
ws2.Range("G2") = "Sum"
ws2.Range("H2") = "=SUM(INDIRECT(""$E2:E""&COUNTA($E:$E)+1))"
ws2.Range("G3") = "Difference"
ws2.Range("H3") = "=SUM(INDIRECT(""$E2:E""&COUNTA($E:$E)+1))"
ws2.Range("G4") = "Sum of Bin"
ws2.Range("H4") = "=SUM(INDIRECT(""$D2:D""&COUNTA($D:$D)+1))"

'------------------------------------------
'use autofilter to create unique list on sheet 2
ws1.Range("A:A").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=ws2.Range("J1"), Unique:=True
'create array of full list and unique
MyUniqueArr = Application.Transpose(ws2.Range("J2:J" & ws2.Range("J" & Rows.Count).End(xlUp).Row))
MyFullArr = Application.Transpose(ws1.Range("A1:A" & ws1.Cells(Rows.Count, 1).End(xlUp).Row))
' place header on unique list
ws2.Range("Extract") = "ID Number"
'Loop through all unique ID numbers
For x = LBound(MyUniqueArr) To UBound(MyUniqueArr)
    For y = LBound(MyFullArr) To UBound(MyFullArr)
        If MyUniqueArr(x) = MyFullArr(y) Then
            MyRW = ws2.Range("A" & Rows.Count).End(xlUp).Row + 1
            ws1.Range("A" & y).Resize(1, 3).Copy ws2.Range("A" & MyRW).Resize(1, 3)
            ws2.Cells(MyRW, 4) = 1
            ws2.Cells(MyRW, 5) = "=$C" & MyRW & "*" & "$D" & MyRW
        End If
    Next y
    Add1 = "D2:D" & MyRW
    Call SolverMacro(Add1, x + 1)
Next x

Application.ScreenUpdating = True
MsgBox "Code took: " & Time - mystart & " seconds to complete."

End Sub

A working example is at the OZGRID thread here: https://www.ozgrid.com/forum/index.php?thread/1229924-how-to-determine-all-invoices-with-the-same-id-that-equal-to-0/&postID=1251250#post1251250

To run the code as it is written you need to create a workbook with sheet1 and sheet 2, then copy your data to sheet1 with the columns A,B & C containing the IDs, Invoice # and $ amount.

Then open sheet 2 and run the code, either by placing a button on the page linked to the ExtractorSub or by running the code from the module.

The code will then create a list of unique ID numbers on sheet 2, fill columns G & H rows 1 to 4 with some headers and formulas. It then copies all of one the matching IDs for each unique ID sequentially and runs a solver loop on them identifying all that add to 0. I have limited the number at the moment to 4 possible solutions but if I look at this again I think there is a way to get stop the loop when no solutions are found which removes this requirement.

At the moment the input:

results in this output:

I am not sure how it will go on 300,000 rows, it might be best to try on a few thousand and see how long it takes to do the solves then increase or just keep copying a few thousand at a time. I can probably make the code more efficient in parts but the solver itself will probably take the majority of the time.