Function to return an array in VBA

Question

I am an accountant and I need to match every customer payment against the outstanding invoices every day, I found a very nice and elegant VBA code published by Michael Schwimmer in this website. https://berndplumhoff.gitbook.io/sulprobil/excel/excel-vba-solutions/accounts-receivable-problem

The code works perfect, it can automatically calculate and list the results that are added up to a specific sum. However, I would like the VBA code to returns the invoice numbers as well. The code passed an array of the values to a function for calculation and then returns the possible solution to Column E, I don't have knowledge in array so don't know how to pass the array of the invoice numbers to the function and return the results. Could anyone help? The code is as below, you can also download the excel workbook from the link I provided. Thanks in advance!

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

Answer 1

You could probably get the invoice numbers simply with a VLOOKUP but here is a VBA solution. I have changed the values in the Sofar collection from invoice amounts to the index number for that amount. That index number then gives the corresponding invoice number from a new array InvNo .

Update - Sorted by due date

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

Answer 2

Get nth match in Index Please refer this exceljet page for function for getting nth match which is used in index function for finding the match for the nth position given by countif function as last argument of small function. Range in the countif function need to be fixed at the first cell only. So, when we copy the formula below we get relative increment in the 'n' in case of duplicate matches. So, Index function will give the incremental nth position value.

Array CSE(Control+Shift+Enter) Formula for in F3 and copy down

=INDEX(ColEResultRangeFixed,SMALL(IF(ColAValuesRangeFixed=ColEResultCriteria,ROW(ColAValuesRangeFixed)-MIN(ROW(ColAValuesRangeFixed))+1),COUNTIF($ColAValuesRangeFixedFirst,ColEResultCriteria)))

In this case.. CSE Formula in F3 and then copy down

=INDEX($B$2:$B$11,SMALL(IF($A$2:$A$11=E3,ROW($A$2:$A$11)-MIN(ROW($A$2:$A$11))+1),COUNTIF($E$3:E3,E3)))