“It’s not that I’m so smart, it’s just that I stay with problems longer.” [Albert Einstein]


Mr Excel’s challenge of the month of August 2002 stated:

“An accounts receivable department receives a check from a customer for $4,556.92. Upon looking in the accounting system, there are 54 unpaid invoices, ranging from $77.74 to $5,465.45. The payment must be for some exact combination of entire invoices, but we don’t know which invoices are being paid.”

The winning solution was published (external link!) here. Michael Schwimmer presented a nice and elegant solution on his (now retired) website - in German. I translated his version into English because I found it really beautiful. Any errors are mine, I am sure.


Note: I changed the program to indicate that there is no solution in case the program cannot find any with the given tolerance.

See also

The accounts receivable problem is related to the function sbMinCash.

Appendix – cmbCalculate_Click Code

Pleae note that this program needs (uses) ArrayDim.

Please read my Disclaimer.

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)
            ReDim Preserve dAmounts(1 To m - 1)
            Exit For
        End If
    ReDim Preserve dAmounts(1 To UBound(dAmounts) - 1)
    vResult = Combinations(dAmounts, dGoal, dTolerance)
    Application.ScreenUpdating = False
    If ArrayDim(vResult) < 1 Then
        .Cells(3, 4) = "No solution within this tolerance"
        .Range(.Cells(3, 4), .Cells(UBound(vResult) + 3, 4)) = vResult
    End If
    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

   '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
   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
      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
         SoFar.Remove SoFar.Count
         dCompare = dCompare - Elements(i)
      End If
      'Amount too high
      SoFar.Remove SoFar.Count
      Exit For
   End If
Next 'Try next higher amount

End Function

Please read my Disclaimer.

Accounts_Receivable_Problem.xlsm [30 KB Excel file, open and use at your own risk]