Sulprobil
Search…
Accounts Receivable Problem
"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 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.
Tushar Mehta presents a nice algorithm (which can calculate all solutions if you got the time) here.
Please read my Disclaimer.
1
Private Sub cmbCalculate_Click()
2
3
Dim dGoal As Double
4
Dim dTolerance As Double
5
Dim dAmounts() As Double
6
Dim vResult As Variant
7
Dim m As Long
8
Dim n As Long
9
10
With Me
11
12
dGoal = .Range("B2")
13
dTolerance = .Range("C2")
14
ReDim dAmounts(1 To 100)
15
For m = 2 To 101
16
If (.Cells(m, 1) <> "") And (IsNumeric(.Cells(m, 1))) Then
17
dAmounts(m - 1) = .Cells(m, 1)
18
Else
19
ReDim Preserve dAmounts(1 To m - 1)
20
Exit For
21
End If
22
Next
23
ReDim Preserve dAmounts(1 To UBound(dAmounts) - 1)
24
25
vResult = Combinations(dAmounts, dGoal, dTolerance)
26
Application.ScreenUpdating = False
27
.Range("D3:D65536").ClearContents
28
.Range(.Cells(3, 4), .Cells(UBound(vResult) + 3, 4)) = vResult
29
Application.ScreenUpdating = True
30
31
End With
32
33
End Sub
34
35
Function Combinations( _
36
Elements As Variant, _
37
Goal As Double, _
38
Optional Tolerance As Double, _
39
Optional SoFar As Variant, _
40
Optional Position As Long) As Variant
41
42
Dim i As Long
43
Dim k As Long
44
Dim dCompare As Double
45
Dim dDummy As Double
46
Dim vDummy As Variant
47
Dim vResult As Variant
48
49
If Not IsMissing(SoFar) Then
50
51
'Sum of elements so far
52
For Each vDummy In SoFar
53
dCompare = dCompare + vDummy
54
Next
55
56
Else
57
58
'Start elements sorted by amount
59
For i = 1 To UBound(Elements)
60
For k = i + 1 To UBound(Elements)
61
If Elements(k) < Elements(i) Then
62
dDummy = Elements(i)
63
Elements(i) = Elements(k)
64
Elements(k) = dDummy
65
End If
66
Next
67
Next
68
69
Set SoFar = New Collection
70
71
End If
72
73
If Position = 0 Then Position = LBound(Elements)
74
For i = Position To UBound(Elements)
75
76
'Add current element
77
SoFar.Add Elements(i)
78
dCompare = dCompare + Elements(i)
79
80
If Abs(Goal - dCompare) < (0.001 + Tolerance) Then
81
82
'Goal achieved
83
k = 0
84
ReDim vResult(0 To SoFar.Count - 1, 0)
85
For Each vDummy In SoFar
86
vResult(k, 0) = vDummy
87
k = k + 1
88
Next
89
Combinations = vResult
90
Exit For
91
92
ElseIf dCompare < (Goal + 0.001 + Tolerance) Then
93
'Enough room for another element
94
'Call recursively starting with next higher amount
95
vResult = Combinations(Elements, Goal, Tolerance, SoFar, i + 1)
96
If IsArray(vResult) Then
97
Combinations = vResult
98
Exit For
99
Else
100
SoFar.Remove SoFar.Count
101
dCompare = dCompare - Elements(i)
102
End If
103
104
Else
105
106
'Amount too high
107
SoFar.Remove SoFar.Count
108
Exit For
109
110
End If
111
112
Next 'Try next higher amount
113
114
End Function
Copied!
Accounts_Receivable_Problem.xlsm
26KB
Binary
Accounts_Receivable_Problem.xlsm
Last modified 1yr ago
Copy link