About MrExcel Consulting Services Learn Excel Resources Challenge of the Month MrExcel Seminars Message Board MrExcel Store Podcast Search Media Contact Home

 Past Challenge - Accounts Receivable Problem Our August 2002 Challenge is inspired by a recent posting on the MS boards. Thanks to Harlan, Tim, and Tushar for a lively discussion around this problem. Here is the specific problem. 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 complete list of invoices for this specific problem is shown below. On first examination, there could be 2^54 possible combinations - about 18 quadrillion - which would tend to take forever via a brute force method. The August challenge is to document a method for determining which invoices the customer is paying. If there is more than one combination, note that. We are looking for the best general purpose algorithm that could be used every day by accounts receivable departments across the world for similar problems. Whichever method is judged to work the best for the average accounts receivable problem such as this will win our soon-to-be-released Message Board CD. Deadline for entries is August 31, 2002. You can post your entries in the lounge, or e-mail them to Here is the list of 54 open invoice amounts, which you can copy and paste to Excel: ```895.39 83.06 280.71 1021.7 219.1 1587.52 507.08 628.89 222.52 192.65 194.58 764.18 680.23 244.22 89.4 862.12 1842.59 329.97 444.98 630.92 440.93 324.84 978.53 144.77 230.72 456.68 126.69 2487.85 515.11 911.45 983.98 329.17 673.47 409.17 228.31 796.76 116.14 858.97 718.32 346.35 542.12 589.18 789.77 185.58 538.64 441.43 925.39 698.27 5465.45 160.62 722.73 691.83 77.74 365.43 ``` If your local version of Excel requires the decimal place to be a comma, then copy and paste this set instead: ```895,39 83,6 280,71 1021,70 219,10 1587,52 507,8 628,89 222,52 192,65 194,58 764,18 680,23 244,22 89,40 862,12 1842,59 329,97 444,98 630,92 440,93 324,84 978,53 144,77 230,72 456,68 126,69 2487,85 515,11 911,45 983,98 329,17 673,47 409,17 228,31 796,76 116,14 858,97 718,32 346,35 542,12 589,18 789,77 185,58 538,64 441,43 925,39 698,27 5465,45 160,62 722,73 691,83 77,74 365,43 ``` The solution: First off, I never realized that I had posed a question which had 3,514 possible solutions. We had a lively discussion with many possible directions. Ioannis popped in during the middle of the month and kept reporting success, but kept his winning macro a secret until the last minute. Simply for keeping us all baited so well, he caused a lot of anticipation for his macro, shown below. I encourage anyone interested to read the entire 80+ posts here. IOANNIS's winning macro: ```Code: -------------------------------------------------------------------------------- Dim INV() As Long Dim CHECK As Long Dim MAX_CHECK_INVS_No As Integer Dim Sol As Long Dim RESUME_No() As Integer Dim RES_No As Integer Dim RESUME_CALC As Integer Dim MAX_RESUME_No As Integer Dim AA As Long Dim MAX_INVS As Integer Dim MAX_DEPTH As Integer Sub Challenge() ' SORTING Columns("B:B").Select Selection.Sort Key1:=Range("B1"), Order1:=xlAscending, Header:=xlNo, _ OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom ' CLEAR SOLUTION AREA Columns("H:H").Select Selection.ClearContents Columns("M:P").Select Selection.ClearContents Cells(11, 4).Select Selection.Activate Cells(18, 6) = 0 Cells(7, 6) = 0 CHECK = Cells(2, 6) * 100 TOT_INV = Cells(1, 6) ReDim INV(TOT_INV + 1) MaxSum = 0 For i = 1 To TOT_INV INV(i) = Cells(i, 2) * 100 MaxSum = MaxSum + INV(i) Next SUM_INV = 0 MAX_INVS = 0 For i = 1 To TOT_INV SUM_INV = SUM_INV + INV(i) If SUM_INV = CHECK Then MAX_INVS = i: Exit For If SUM_INV > CHECK Then MAX_INVS = i - 1: Exit For Next Cells(3, 6) = MAX_INVS MAX_CHECK_INVS_No = 1 i = 1 For i = TOT_INV To 2 Step -1 SUM_INV = INV(i) If SUM_INV = CHECK Then GoTo Exit_for For k = 1 To i SUM_INV = SUM_INV + INV(k) If SUM_INV <= CHECK Then GoTo Exit_for End If Next Next Exit_for: MAX_CHECK_INVS_No = i INV(MAX_CHECK_INVS_No + 1) = MaxSum Cells(4, 6) = MAX_CHECK_INVS_No Sol = 0 AA = 0 Cells(14, 6) = Time 'Application.ScreenUpdating = False Find_Sol 0, "", 0 Cells(10, 5) = Str(MAX_CHECK_INVS_No) Cells(15, 6) = Time Application.ScreenUpdating = True End Sub Sub Find_Sol(No_01 As Integer, NN_01 As String, SINVS_01 As Long) For No_02% = No_01 + 1 To MAX_CHECK_INVS_No NN_02\$ = NN_01 + Str(No_02%) SINVS_02& = SINVS_01 + INV(No_02%) If SINVS_02& > CHECK Then Exit For If SINVS_02& = CHECK Then Sol = Sol + 1 If Sol > 65536 Then Sol = 1: COPY_SOLUTIONS Cells(Sol, 8) = NN_02\$ 'Cells(10, 5) = NN_02\$ Cells(15, 6) = Time End If If (SINVS_02& + INV(No_02% + 1)) > CHECK Then If (INV(No_02%) = INV(No_02% + 1)) Then GoTo END_LOOP MAX_No_01% = MAX_CHECK_INVS_No + 1 No_02% = No_02% + 1 START_LOOP: CH_No% = MAX_No_01% - No_02% If CH_No% > 1 Then CH_No_m% = CH_No% / 2 + No_02% If (SINVS_01 + INV(CH_No_m%)) > CHECK Then MAX_No_01% = CH_No_m% GoTo START_LOOP End If If (SINVS_01 + INV(CH_No_m%)) = CHECK Then Sol = Sol + 1 If Sol > 65536 Then Sol = 1: COPY_SOLUTIONS Cells(Sol, 8) = NN_01 + Str(CH_No_m%) Exit For End If If (SINVS_01 + INV(CH_No_m%)) < CHECK Then No_02% = CH_No_m% GoTo START_LOOP End If Else If CH_No% = 1 Then No_02% = MAX_No_01% - 1 If (SINVS_01 + INV(No_02%)) = CHECK Then Sol = Sol + 1 If Sol > 65536 Then Sol = 1: COPY_SOLUTIONS Cells(Sol, 8) = NN_01 + Str(No_02%) Exit For End If End If Exit For End If End If END_LOOP: Find_Sol No_02%, NN_02\$, SINVS_02& Next_No_02: Next No_02 End Sub Sub RESUME_LAST_SOLUTION() TOT_INV = Cells(1, 6) ReDim RESUME_No(TOT_INV) LAST_SOLUTION_No = Cells(5, 6) If LAST_SOLUTION_No = 0 Then Exit Sub LAST_SOLUTION = Cells(LAST_SOLUTION_No, 8) Range("D:D").Select Selection.ClearContents If LAST_SOLUTION <> "" Then LAST_SOLUTION = Trim(LAST_SOLUTION) + " " SOL_LEN = Len(LAST_SOLUTION) START_LEN = 1 AA = 1 For i = START_LEN To SOL_LEN No = InStr(i, LAST_SOLUTION, " ") Cells(AA, 4) = Mid(LAST_SOLUTION, i, No - i) RESUME_No(AA) = Cells(AA, 4) i = No AA = AA + 1 Next End If End Sub Sub COPY_SOLUTIONS() AC_NAME = ActiveSheet.Name N = 0 SOL_NAME = Cells(2, 6) Do N = N + 1 SOL_NAME_01 = Trim(Str(SOL_NAME)) + "_" + Trim(Str(N)) Loop Until Exist_SHEET(SOL_NAME_01) = 0 Cells(7, 6) = N Create_SOLUTIONS_PAGE (SOL_NAME_01) Sheets(AC_NAME).Select Range("H1:I65536").Select Selection.Copy Sheets(SOL_NAME_01).Select Range("B1").Select ActiveSheet.Paste Columns("B:C").AutoFit Range("B1").Select Sheets(AC_NAME).Select Range("H1:I65536").Select Selection.ClearContents Range("E10").Activate End Sub Function Exist_SHEET(SH_NAME) Exist_SHEET = 0 For Each SH In Sheets If SH.Name = SH_NAME Then Exist_SHEET = 1: Exit For Next SH End Function Sub Create_SOLUTIONS_PAGE(SH_NAME) If Exist_SHEET(SH_NAME) Then Else Set NewSheet = Worksheets.Add NewSheet.Name = SH_NAME End If End Sub Sub RESUME_Challenge() If Cells(5, 6) = 0 Then Exit Sub ' SORTING Columns("B:B").Select Selection.Sort Key1:=Range("B1"), Order1:=xlAscending, Header:=xlNo, _ OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom RESUME_LAST_SOLUTION RESUME_CALC = 1 Cells(11, 4).Select Selection.Activate MAX_RESUME_No = Cells(8, 6) CHECK = Cells(2, 6) * 100 TOT_INV = Cells(1, 6) ReDim INV(TOT_INV + 1) MaxSum = 0 For i = 1 To TOT_INV INV(i) = Cells(i, 2) * 100 MaxSum = MaxSum + INV(i) Next SUM_INV = 0 MAX_INVS = 0 For i = 1 To TOT_INV SUM_INV = SUM_INV + INV(i) If SUM_INV = CHECK Then MAX_INVS = i: Exit For If SUM_INV > CHECK Then MAX_INVS = i - 1: Exit For Next Cells(3, 6) = MAX_INVS MAX_CHECK_INVS_No = 1 For i = TOT_INV To 2 Step -1 SUM_INV = INV(i) If SUM_INV = CHECK Then GoTo Exit_for For k = 1 To i SUM_INV = SUM_INV + INV(k) If SUM_INV <= CHECK Then GoTo Exit_for End If Next Next_i: Next Exit_for: MAX_CHECK_INVS_No = i INV(MAX_CHECK_INVS_No + 1) = MaxSum Cells(4, 6) = MAX_CHECK_INVS_No CHECK = MaxSum * 2 RES_No = 0 Sol = Cells(5, 6) Cells(18, 6).Value = Cells(19, 6).Value Cells(14, 6) = Time No_01% = RESUME_No(1) 'Application.ScreenUpdating = False RESUME_Find_Sol No_01%, "", 0 Cells(10, 5) = Str(MAX_CHECK_INVS_No) Cells(15, 6) = Time Application.ScreenUpdating = True End Sub Sub RESUME_Find_Sol(No_01 As Integer, NN_01 As String, SINVS_01 As Long) For No_02% = No_01 + 1 To MAX_CHECK_INVS_No If RESUME_CALC = 1 Then RES_No = RES_No + 1 If RES_No > MAX_RESUME_No Then RESUME_CALC = 2 CHECK = Cells(2, 6) * 100 No_02% = No_02% - 1 Exit For Else No_02% = RESUME_No(RES_No) End If End If NN_02\$ = NN_01 + Str(No_02%) SINVS_02& = SINVS_01 + INV(No_02%) If SINVS_02& > CHECK Then Exit For If SINVS_02& = CHECK Then Sol = Sol + 1 If Sol > 65536 Then Sol = 1: COPY_SOLUTIONS Cells(Sol, 8) = NN_02\$ 'Cells(10, 5) = NN_02\$ Cells(15, 6) = Time End If If (SINVS_02& + INV(No_02% + 1)) > CHECK Then If (INV(No_02%) = INV(No_02% + 1)) Then GoTo END_LOOP MAX_No_01% = MAX_CHECK_INVS_No + 1 No_02% = No_02% + 1 START_LOOP: CH_No% = MAX_No_01% - No_02% If CH_No% > 1 Then CH_No_m% = CH_No% / 2 + No_02% If (SINVS_01 + INV(CH_No_m%)) > CHECK Then MAX_No_01% = CH_No_m% GoTo START_LOOP End If If (SINVS_01 + INV(CH_No_m%)) = CHECK Then Sol = Sol + 1 If Sol > 65536 Then Sol = 1: COPY_SOLUTIONS Cells(Sol, 8) = NN_01 + Str(CH_No_m%) Exit For End If If (SINVS_01 + INV(CH_No_m%)) < CHECK Then No_02% = CH_No_m% GoTo START_LOOP End If Else If CH_No% = 1 Then No_02% = MAX_No_01% - 1 If (SINVS_01 + INV(No_02%)) = CHECK Then Sol = Sol + 1 If Sol > 65536 Then Sol = 1: COPY_SOLUTIONS Cells(Sol, 8) = NN_01 + Str(No_02%) Exit For End If End If Exit For End If End If END_LOOP: RESUME_Find_Sol No_02%, NN_02\$, SINVS_02& Next_No_02: Next No_02 End Sub -------------------------------------------------------------------------------- .. Module 2 ... Code: -------------------------------------------------------------------------------- Dim Comp_No() Function Print_No(Combination As String, Base As Integer) As Variant Application.ScreenUpdating = False Dim COMP As Integer Dim Max_COMP As Integer Dim ss, dd, i, k As Integer Dim Co_02, Co_01 As Integer Max_COMP = Val(SEPARATE_COMP(Combination, 0)) ReDim Comp_No(Max_COMP) Dim Comp_SER(10, 2) For COMP = 1 To Max_COMP Comp_No(COMP) = Val(SEPARATE_COMP(Combination, COMP)) Next ss = 0: dd = 0 Select Case Max_COMP Case 1 Print_No = CDec(1) For COMP = 1 To Comp_No(1) - 1 Print_No = CDec(Print_No + Count_Combinations(COMP, Base)) Next Case Base: Print_No = CDec(Max_COMP) Case Else Co_01 = Comp_No(1) For i = 2 To Max_COMP Co_02 = Comp_No(i) If Co_02 - Co_01 = 1 Then Co_01 = Co_02 dd = dd + 1 Else ss = ss + 1 Comp_SER(ss, 1) = Co_01 Comp_SER(ss, 2) = Co_02 Co_01 = Co_02 End If Next If ss = 0 Then Print_No = CDec(Max_COMP) For COMP = 1 To Comp_No(1) - 1 Print_No = CDec(Print_No + Count_Combinations(COMP, Base)) Next Else Print_No = CDec(Print_No + Max_COMP) For i = 1 To ss For k = Comp_SER(i, 1) + 1 To Comp_SER(i, 2) - 1 Print_No = CDec(Print_No + Count_Combinations(k, Base)) Next Next For COMP = 1 To Comp_No(1) - 1 Print_No = CDec(Print_No + Count_Combinations(COMP, Base)) Next End If End Select Application.ScreenUpdating = True End Function Function Count_Combinations(No As Integer, Base As Integer) As Variant Count_Combinations = CDec(2 ^ (Base - No)) End Function Function SEPARATE_COMP(CELL_TEXT As String, No As Integer) As String Application.ScreenUpdating = False If CELL_TEXT = "" Then SEPARATE_COMP = "": Exit Function ' COUNT WORDS CELL_TEXT = Trim(CELL_TEXT) + " " TEXT_LEN% = Len(CELL_TEXT) START_LEN% = 1 COUNTER_No% = 1 For i% = START_LEN% To TEXT_LEN% FOUNT_POSITION_No% = InStr(i%, CELL_TEXT, " ") WORD_FOUND = Mid(CELL_TEXT, i%, FOUNT_POSITION_No% - i%) i% = FOUNT_POSITION_No% If Trim(WORD_FOUND) <> "" Then COUNTER_No% = COUNTER_No% + 1 End If Next MAX_WORDS% = COUNTER_No% - 1 If No = 0 Then SEPARATE_COMP = MAX_WORDS% Application.ScreenUpdating = True Exit Function End If ' PUT WORDS IN ARRAY ReDim WORDS_FOUND(MAX_WORDS%) START_LEN% = 1 COUNTER_No% = 1 For i% = START_LEN% To TEXT_LEN% FOUNT_POSITION_No% = InStr(i%, CELL_TEXT, " ") WORD_FOUND = Mid(CELL_TEXT, i%, FOUNT_POSITION_No% - i%) i% = FOUNT_POSITION_No% If Trim(WORD_FOUND) <> "" Then WORDS_FOUND(COUNTER_No%) = WORD_FOUND COUNTER_No% = COUNTER_No% + 1 End If Next If No > MAX_WORDS% Then No = MAX_WORDS% SEPARATE_COMP = WORDS_FOUND(No) Application.ScreenUpdating = True End Function ``` Congratulations to IOANNIS and to everyone who participated in this month's challenge!

Excel is a registered trademark of the Microsoft® Corporation.

All contents Copyright 1998-2008 by MrExcel Consulting.