如何确定发票号码总计为 0

Question

我已经更新但尚未完善代码，如果发帖者仍然感兴趣并想澄清这个结果是否适合他们，我会完成它。如前所述，此链接： https://thedailycpa.com/identifying-excel-entries-that-add-up-to-a-specific-value/

有针对各个 ID 的解决方案，那么： https://stackoverflow.com/questions/41643134/vba-sub-not-defined-for-solver 和 https://stackoverflow.com/questions/15498429/loop-with-solver-vba

开始指向 VBA 解决方案。

一旦您激活了第一个链接中概述的求解器插件（它本身附带 excel，因此不需要下载），您就可以在模块中按如下方式运行代码：

   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

此处的 OZGRID 线程中有一个工作示例：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

要按照编写的代码运行，您需要创建一个包含 Sheet1 和 Sheet 2 的工作簿，然后将数据复制到 Sheet1，其中 A、B 和 C 列包含 ID、发票号和金额。

然后打开工作表 2 并运行代码，可以通过在链接到 ExtractorSub 的页面上放置一个按钮或通过从模块运行代码。

然后，代码将在工作表 2 上创建一个唯一 ID 号列表，用一些标题和公式填充 G 列和 H 行 1 至 4。然后，它会按顺序复制每个唯一 ID 的所有匹配 ID，并对它们运行求解器循环，识别所有加法为 0 的 ID。我目前将数字限制为 4 个可能的解决方案，但如果我再次查看，我认为有一种方法可以在未找到解决方案时停止循环，从而消除此要求。

此时输入：

输出结果如下：

我不确定 300,000 行会如何，最好先尝试几千行，看看解决需要多长时间，然后增加或只是一次复制几千行。我可能可以部分提高代码效率，但求解器本身可能会占用大部分时间。

Answer 1