“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.
Appendix – cmbCalculate_Click Code
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) 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
Please read my Disclaimer.
Accounts_Receivable_Problem.xlsm [27 KB Excel file, open and use at your own risk]