VBA中返回数组的函数

我是一名会计师，我需要每天将每笔客户付款与未清发票进行匹配，我在这个网站上发现了 Michael Schwimmer 发布的非常漂亮和优雅的 VBA 代码。https://berndplumhoff.gitbook.io/sulprobil/excel/excel-vba-solutions/accounts-receivable-problem https://berndplumhoff.gitbook.io/sulprobil/excel/excel-vba-solutions/accounts-receivable-problem

该代码运行完美，它可以自动计算并列出加起来达到特定总和的结果。但是，我希望 VBA 代码也返回发票号码。该代码将值的数组传递给函数进行计算，然后将可能的解决方案返回到 E 列，我对数组没有了解，所以不知道如何将发票号码的数组传递给函数并返回结果。有人可以帮忙吗？代码如下，您也可以从以下地址下载excel工作簿link https://berndplumhoff.gitbook.io/sulprobil/excel/excel-vba-solutions/accounts-receivable-problem我提供的。提前致谢！

Private Sub cmbCalculate_Click()

    Dim dGoal As Double
    Dim dTolerance As Double
    Dim dAmounts() As Double
    Dim vResult As Variant
    Dim m As Long
    Dim n As Long
    
With Me
   
    dGoal = .Range("B2")
    dTolerance = .Range("C2")
    ReDim dAmounts(1 To 100)
    For m = 2 To 101
    If (.Cells(m, 1) <> "") And (IsNumeric(.Cells(m, 1))) Then
        dAmounts(m - 1) = .Cells(m, 1)
    Else
        ReDim Preserve dAmounts(1 To m - 1)
        Exit For
    End If
    Next
    ReDim Preserve dAmounts(1 To UBound(dAmounts) - 1)

    vResult = Combinations(dAmounts, dGoal, dTolerance)
    Application.ScreenUpdating = False
    .Range("D3:D65536").ClearContents
    .Range(.Cells(3, 4), .Cells(UBound(vResult) + 3, 4)) = vResult
    Application.ScreenUpdating = True

End With

End Sub

Function Combinations( _
   Elements As Variant, _
   Goal As Double, _
   Optional Tolerance As Double, _
   Optional SoFar As Variant, _
   Optional Position As Long) As Variant
  
Dim i As Long
Dim k As Long
Dim dCompare As Double
Dim dDummy As Double
Dim vDummy As Variant
Dim vResult As Variant

If Not IsMissing(SoFar) Then

   'Sum of elements so far
   For Each vDummy In SoFar
      dCompare = dCompare + vDummy
   Next
  
Else

   'Start elements sorted by amount
   For i = 1 To UBound(Elements)
       For k = i + 1 To UBound(Elements)
           If Elements(k) < Elements(i) Then
               dDummy = Elements(i)
               Elements(i) = Elements(k)
               Elements(k) = dDummy
           End If
       Next
   Next
  
   Set SoFar = New Collection
  
End If

If Position = 0 Then Position = LBound(Elements)
For i = Position To UBound(Elements)

   'Add current element
   SoFar.Add Elements(i)
   dCompare = dCompare + Elements(i)
  
   If Abs(Goal - dCompare) < (0.001 + Tolerance) Then
  
      'Goal achieved
      k = 0
      ReDim vResult(0 To SoFar.Count - 1, 0)
      For Each vDummy In SoFar
         vResult(k, 0) = vDummy
         k = k + 1
      Next
      Combinations = vResult
      Exit For
     
   ElseIf dCompare < (Goal + 0.001 + Tolerance) Then
      'Enough room for another element
      'Call recursively starting with next higher amount
      vResult = Combinations(Elements, Goal, Tolerance, SoFar, i + 1)
      If IsArray(vResult) Then
         Combinations = vResult
         Exit For
      Else
         SoFar.Remove SoFar.Count
         dCompare = dCompare - Elements(i)
      End If
     
   Else
  
      'Amount too high
      SoFar.Remove SoFar.Count
      Exit For
     
   End If
  
Next 'Try next higher amount

End Function

您可能可以简单地使用 VLOOKUP 获取发票号码，但这里有一个 VBA 解决方案。我已经更改了中的值Sofar从发票金额收集到该金额的索引号。然后，该索引号给出新数组中相应的发票号InvNo.

更新 - 按截止日期排序

Sub cmbCalculate_Click()

    Dim ws As Worksheet, dAmounts() As Double, sInvno() As String
    Dim i As Long, dSum As Double
    Dim dtDue() As Date
   
    Set ws = Me
    i = ws.Cells(Rows.Count, "A").End(xlUp).Row
    ReDim dAmounts(1 To i - 1)
    ReDim sInvno(1 To i - 1)
    ReDim dtDue(1 To i - 1)

   ' fill array
    For i = 1 To UBound(dAmounts)
        dAmounts(i) = ws.Cells(i + 1, "A")
        sInvno(i) = ws.Cells(i + 1, "B")
        dtDue(i) = ws.Cells(i + 1, "C")
        dSum = dSum + dAmounts(i)
    Next
    ' sort array
    Call BubbleSort(dAmounts, sInvno, dtDue)
    Dim n: For n = LBound(dAmounts) To UBound(dAmounts): Debug.Print n, dAmounts(n), sInvno(n), dtDue(n): Next

    Dim dGoal As Double, dTolerance As Double, vResult As Variant
    dGoal = ws.Range("D2")
    dTolerance = ws.Range("E2")

    ' check possible
    If dGoal > dSum Then
         MsgBox "Error : Total for Invoices " & Format(dSum, "#,##0.00") & _
         " is less than Goal " & Format(dGoal, "#,##0.00")
    Else
        ' solve and write to sheet
        vResult = Combinations2(dAmounts, sInvno, dtDue, dGoal, dTolerance)
        If IsArray(vResult) Then
            With ws
                .Range("F3:H" & Rows.Count).ClearContents
                .Range("F3").Resize(UBound(vResult), 3) = vResult
            End With
            MsgBox "Done"
        Else
            MsgBox "Cannot find suitable combination", vbCritical
        End If
     End If

End Sub


Function Combinations2( _
    Elements As Variant, _
    Invno As Variant, _
    Due As Variant, _
    Goal As Double, _
    Optional Tolerance As Double, _
    Optional SoFar As Variant, _
    Optional Position As Long) As Variant

    Dim i As Long, n As Long, dCompare As Double

    ' summate so far
    If IsMissing(SoFar) Then
        Set SoFar = New Collection
    Else
        For i = 1 To SoFar.Count
            dCompare = dCompare + Elements(SoFar(i))
        Next
    End If

    If Position = 0 Then Position = LBound(Elements)
    For i = Position To UBound(Elements)

        SoFar.Add CStr(i)
        dCompare = dCompare + Elements(i)

        ' check if target achieved
        If Abs(Goal - dCompare) < (0.001 + Tolerance) Then

            'Goal achieved
            Dim vResult As Variant
            ReDim vResult(1 To SoFar.Count, 1 To 3)
            For n = 1 To SoFar.Count
               vResult(n, 1) = Elements(SoFar(n))
               vResult(n, 2) = Invno(SoFar(n))
               vResult(n, 3) = Due(SoFar(n))
            Next
            Combinations2 = vResult
    
        ElseIf dCompare < (Goal + 0.001 + Tolerance) Then
            'Enough room for another element
            'Call recursively starting with next higher amount
            vResult = Combinations2(Elements, Invno, Due, Goal, Tolerance, SoFar, i + 1)
            If IsArray(vResult) Then
                 Combinations2 = vResult
                 Exit For
            Else
                 SoFar.Remove SoFar.Count
                 dCompare = dCompare - Elements(i)
            End If
        Else
      
            'Amount too high
            SoFar.Remove SoFar.Count
            Exit For
       End If
    Next
End Function

Sub BubbleSort(ByRef ar1 As Variant, ByRef ar2 As Variant, ByRef ar3 As Variant)
   ' sort both arrays
   Dim d, s, i As Long, k As Long, dt As Date
   For i = 1 To UBound(ar1)
       For k = i + 1 To UBound(ar1)
           If (ar1(k) < ar1(i)) Or _
              (ar1(k) = ar1(i) _
           And ar3(k) < ar3(i)) Then
               d = ar1(i)
               ar1(i) = ar1(k)
               ar1(k) = d
               s = ar2(i)
               ar2(i) = ar2(k)
               ar2(k) = s
               dt = ar3(i)
               ar3(i) = ar3(k)
               ar3(k) = dt
           End If
       Next
   Next
End Sub