August Challenge of the Month Discussion

[MrExcel]

Post your solutions to the August Challenge of the Month here.

_________________
MrExcel.com Consulting

[ This Message was edited by: MrExcel on 2002-07-31 12:21 ]

[Jay Petrulis]

Hi,

Not really interested in the CD, but *very* interested in the challenge. This is an awesome question!!!

First stab at it...still need to make this much more efficient.

This calls a recursive subroutine to get the cumulative combinations of N things taken 1...K at a time, then loops through the array of data points to determine if the points match the total.

Since there are 53 (yes, 53) data points to evaluate, I capped the search at up to 8 individual entries. The limit would be 1 billion+ potential outcomes. And since this is a first stab, I didn't want to test it with a full run.

This is a UDF which writes the answers to a column. If called from Row 1, you can have up to 65,536 unique solutions. The array will likely bomb with any more (else will cut off the rest???).

The function is called "Invoice Possibilities" and makes the following function calls

QuickSortVariants -- as posted by Ivan Maola.

Split97 -- as posted to microsoft.public.excel.programming by Myrna Larson (she is a retired MD and a MS MVP who is awesome). Can be replaced with Split for those using XL 2000 or XP

Combinations -- with a call to a subroutine RecursiveCombinations. I scoured the Internet to try to find recursive routines for VBA. Many for C and other languages, but I cannot read them. I have a good idea exactly how this works, but not enough of a grasp to explain it yet (soon).

I do *not* make good use of the sorted set yet. I included it to (eventually) break out of a loop if the subtotal of the combination is greater than the target.

Also, suppose the target is negative, and all entries are positive. That, and similar possibilities should be tested first and if true, then exit the routine with your answer.

OK, more on this as it gets refined and as others post. Crticism/suggestions appreciated. If there is a part that can be junked, let me know. Always willing to redo for a good cause.

Specific questions
1. Can collections be manipulated like arrays?
2. Can a collection be transferred wholesale to an array?
3. Can you delete a collection in one shot?

OK, here is the code...

Option Explicit
Dim fn As WorksheetFunction   'standard shortcut to call Excel functions in VBA

Function Invoice_Possibilities(GoalValue As Double, DataSet)
Set fn = Application.WorksheetFunction
'''  This assumes that GoalValue is > 0.

''''''''''''VARIABLE DECLARATIONS'''''''''''''''''''
'
''' First pass through the function arguments.  Text entries are eliminated.
Dim FirstSet As Variant  '''    Gets the search values (DataSet)
'                        '''    into a one dimensional array

''' If DataSet is a range of values then...
Dim Cell As Range
Dim FirstCounter  As Integer
Dim NumNegative As Integer

''' Second pass through the data is used to find out
''' the number of valid entries.  If there are no entries < 0
''' all entries greater than the GoalValue are removed.
''' Note:  Zero entries are eliminated if target <> 0!!!!  (is not introduced yet)
Dim SecondSet
Dim SecondCounter As Integer
Dim x As Integer  ' counter variable

Dim SolutionArray
Dim Counter As Double  '''must change to double from long

Dim t As Double, u As Double, v As Double, w As Double
Dim SubTotSum As Double, AnswerCnt As Long, FinalArray
Dim s As Integer, strS As String

''''''''''''DATA PREPARATION -- 1st pass'''''''''''''''''''
''' Determine the type of data in the dataset
''' and read into array FirstSet
''' Array --> "Variant()"
''' Range --> "Range"

If TypeName(DataSet) = "Range" Then
    ReDim FirstSet(1 To DataSet.Cells.Count) As Double
    For Each Cell In DataSet
        If IsNumeric(Cell) And Not IsEmpty(Cell) Then
            FirstCounter = FirstCounter + 1
            FirstSet(FirstCounter) = Cell
            If Cell < 0 Then
                NumNegative = NumNegative + 1
            End If
        End If
    Next Cell
ElseIf TypeName(DataSet) = "Variant()" Then
    FirstSet = DataSet
Else
    ' Exit function if values are unworkable
    Invoice_Possibilities = CVErr(xlErrNum)
    Exit Function
End If

'''  Exit function if no valid entries on first pass
If FirstCounter = 0 Then
    Invoice_Possibilities = CVErr(xlErrNum)
    Exit Function
End If
''''''''''''''''''''''''''''''''''''''''''''''''''''


'''''''''''''SECOND PASS''''''''''''''''''''''''''''
'
'
'''  This should allow us to start with the minimum number of
'''  choices to loop through.  If there are no negative numbers,
'''  this will eliminate any impossible values, i.e., > GoalValue.
'''  Note:  It is not possible to eliminate duplicated numbers.
'''  Suppose the out-of-balance is 375.00 and there are 3 entries
'''  of 125.00.  Dropping two duplicates will drop a solution.

If NumNegative Then
    SecondSet = FirstSet ' can't eliminate if negatives exist
Else
    ReDim SecondSet(1 To UBound(FirstSet) - LBound(FirstSet) + 1)
    For x = LBound(FirstSet) To UBound(FirstSet)
        If FirstSet(x) <= GoalValue Then
            SecondCounter = SecondCounter + 1
            SecondSet(SecondCounter) = FirstSet(x)
        End If
    Next x
    On Error Resume Next
        ReDim Preserve SecondSet(1 To SecondCounter)
    On Error GoTo 0
    Err.Clear
End If
'''  Exit function if no valid entries after second pass
If SecondCounter = 0 Then
    Invoice_Possibilities = CVErr(xlErrNum)
    Exit Function
End If
''''''''''''''''''''''''''''''''''''''''''''''''''''
'
'
''''''''''Next step -- find total possibilities'''''
''' Need to find the cumulative combinations of N things
''' taking R at a time as R goes from 1 to N.  This
''' binomial tree is equal to 2^N.  If the "select zero"
''' option is not available, there are 2^N - 1 total possible.
'''
''' Each is loaded into its own array

Call QuickSortVariants(SecondSet, LBound(SecondSet), UBound(SecondSet))

t = fn.Min(8, SecondCounter)
ReDim SolutionArray(1 To t)
For x = 1 To t
    SolutionArray(x) = Combinations(SecondCounter, x)
Next x

    For u = 1 To t
        For v = 1 To fn.Combin(t, u)
            For w = 0 To fn.Min(fn.Combin(t, u) - 1, u - 1)
                SubTotSum = SubTotSum + SecondSet(SolutionArray(u)(v)(w))
                If SubTotSum > GoalValue Then GoTo NextVlist
            Next w
            
            If fn.Round(SubTotSum, 4) = fn.Round(GoalValue, 4) Then
                AnswerCnt = AnswerCnt + 1
                If AnswerCnt = 1 Then
                    ReDim FinalArray(1 To AnswerCnt)
                Else
                    ReDim Preserve FinalArray(1 To AnswerCnt)
                End If
                For s = 0 To fn.Max(0, w - 1)
                    strS = strS & SecondSet(SolutionArray(u)(v)(s)) & "| "
                Next s
                FinalArray(AnswerCnt) = Left(Trim(strS), Len(Trim(strS)) - 1)
                strS = ""
            End If
        
NextVlist:
        SubTotSum = 0
        Next v
    Next u

If AnswerCnt = 0 Then
    Invoice_Possibilities = "no matches found"
Else
    Invoice_Possibilities = fn.Transpose(FinalArray)
End If
End Function



Function Combinations(ByVal N As Integer, ByVal K As Integer)
Dim CombinCollection As New Collection
Dim x As Long
Set fn = Application.WorksheetFunction

ReDim CombinArray(1 To fn.Combin(N, K))

RecursiveCombinations CombinCollection, N, K, 1, ""

With CombinCollection
    If .Count = 0 Then
        Exit Function
    Else
        For x = .Count To 1 Step -1
            CombinArray(x) = Split97(Left(CombinCollection(x), _
            Len(CombinCollection(x)) - 1), ",")
            
            CombinCollection.Remove (x)
        Next x
    End If
End With
Combinations = CombinArray
End Function



Sub RecursiveCombinations(CombinCollection, ByVal N As Integer, _
ByVal K As Integer, ByVal i As Integer, ByVal strArray As String)
Dim Counter As Double

If K > N - i + 1 Then Exit Sub
If K = 0 Then
    CombinCollection.Add strArray
    Exit Sub
End If

RecursiveCombinations CombinCollection, N, K - 1, i + 1, strArray & i & ","
RecursiveCombinations CombinCollection, N, K, i + 1, strArray

End Sub




Sub QuickSortVariants(vArray As Variant, inLow As Long, inHi As Long)
      
'''  Routine posted by Ivan F. Maola to MrExcel.com Message Board
'''  http://www.mrexcel.com/board/viewtop...=16211&forum=2
'''  Original author unknown
'''  Comments deleted in code below


   Dim pivot   As Variant
   Dim tmpSwap As Variant
   
   Dim tmpLow  As Long
   Dim tmpHi   As Long
    
   tmpLow = inLow
   tmpHi = inHi
    
   pivot = vArray((inLow + inHi)  2)
  
   While (tmpLow <= tmpHi)
  
      While (vArray(tmpLow) < pivot And tmpLow < inHi)
         tmpLow = tmpLow + 1
      Wend
      
      While (pivot < vArray(tmpHi) And tmpHi > inLow)
         tmpHi = tmpHi - 1
      Wend

      If (tmpLow <= tmpHi) Then
      
         tmpSwap = vArray(tmpLow)
         vArray(tmpLow) = vArray(tmpHi)
         vArray(tmpHi) = tmpSwap
         
         tmpLow = tmpLow + 1
         tmpHi = tmpHi - 1
      End If
   
   Wend
  
   If (inLow < tmpHi) Then QuickSortVariants vArray, inLow, tmpHi
   If (tmpLow < inHi) Then QuickSortVariants vArray, tmpLow, inHi
  
End Sub



Function Split97(sString As String, Optional sDelim As String = " ", _
Optional ByVal Limit As Long = -1, _
Optional Compare As Long = vbBinaryCompare) As Variant

''''''''''''''''''''''''''''
'   Split97 mirrors the Split function introduced in XL2000
'   Author Myrna Larson
'   posted to microsoft.public.excel.programming 13 Nov 2001

Dim vOut As Variant, StrLen As Long
Dim DelimLen As Long, Lim As Long
Dim N As Long, p1 As Long, p2 As Long

StrLen = Len(sString)
DelimLen = Len(sDelim)
ReDim vOut(0 To 0)

If StrLen = 0 Or Limit = 0 Then
 ' return array with 1 element which is empty
ElseIf DelimLen = 0 Then
    vOut(0) = sString ' return whole string in first array element
Else
    Limit = Limit - 1 ' adjust from count to offset
    N = -1
    p1 = 1
    
    Do While p1 <= StrLen
        p2 = InStr(p1, sString, sDelim, Compare)
        If p2 = 0 Then p2 = StrLen + 1
        N = N + 1
        If N > 0 Then ReDim Preserve vOut(0 To N)
        If N = Limit Then
            vOut(N) = Mid$(sString, p1) ' last element contains entire tail
            Exit Do
        Else
            vOut(N) = Mid$(sString, p1, p2 - p1) ' extract this piece of string
        End If
            p1 = p2 + DelimLen ' advance start past delimiter
    Loop
End If
Split97 = vOut
End Function

I haven't finished commenting this, and you'll notice that my variable declarations got a lot less descriptive as I went on -- blame it on laziness.

_________________
Bye,
Jay

EDIT: Changed the separator to a | from a comma to eliminate confusion with systems having the comma as the decimal separator.

[ This Message was edited by: Jay Petrulis on 2002-08-02 08:01 ]

[W. Pooh]

On 2002-07-31 12:08, MrExcel wrote:
Post your solutions to the August Challenge of the Month here.

_________________
MrExcel.com Consulting

[ This Message was edited by: MrExcel on 2002-07-31 12:21 ]

Could you post the link to the recent posting on the MS boards that you mentioned, please?

[W. Pooh]

“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.”


This is an interesting mental exercise but in the real world, I cannot imagine that it is a necessity or even desirable.
It involves guessing the payer’s intention. If a match is found that is not made up of the earliest dated invoices, it may not be appropriate to assume that the payer intended to settle these invoices – he may want the payment offset against the earliest invoices.
In any event, because of the potentially huge number of combinations, I doubt that there is an Excel solution that will prove to be practical.

Normal practical requirements merely need to set off unallocated payments against the earliest dated invoices (with a partial offset for the last one if necessary) and then to advise the payer to what invoices the payment has been applied.
It is simple to automate this - both the set-off and the issue of the advice to the payer.
Even if an exact set off is made, whether or not it is against the earliest invoices, an advice to the payer is still advisable procedure.

Since earlier invoices are normally settled first, perhaps a partial automated check could be run to try matching the payment with the invoices.
For example, the combinations could be checked for the earliest invoices that add up to just over the amount paid plus (say) 4-5 invoices. If a match were found, OK – otherwise just set off against the earliest invoices.
This would remove the potentially impractical processing of huge combinations.

It’s an interesting challenge, but I don’t think it’s one that has much useful application in the context of managing accounts receivable.

[Jay Petrulis]

Hi,

The link is here...

http://groups.google.com/groups?hl=e...40tkmsftngxa06

It is also in my posting to Chris Davison's thread "Longest Macro" in the XL-Lounge from a few days ago.

This problem won't be "solved" with an algorithm, at least not by anyone using Excel by August 31. This challenge is a "Holy Grail" of computer science. However, that doesn't mean the exercise is of no use. In fact, I think it is highly instructive about using Excel and has a lot of practical use for smaller data sets. So I wouldn't worry too much about how truly applicable this is for the specific problem description.

Bear in mind Harlan's message in the newsgroup thread that human capacity to find the match(es) far exceeds the capacity of the fastest supercomputer.

The key part is to try to remove as many combinations as you can. The more you discard the faster the program will run through the valid combinations.

In Chris' thread, I think PaddyD responded about this being a P=NP (complete or hard???) problem, like the travelling salesman and the knapsack problem.

BTW, the travelling salesman problem has been solved (...find the shortest route a salesman will take if he is to visit each of the xxxx number of US cities/towns over some threshold population, visiting each locale once). It was done with a distributed grid computer (thousands of linked computers lending their muscle) after two weeks or so of continuous processing!!!!

Give it a shot. A group effort will result in a routine that will be optimum given our limited resources and abilities (some of the greatest minds in mathematics and computer science have worked on this, so you and I won't get too far). In any event, I learned a ton from the thread and trying the exercise. Case in point -- look at my routine. At the end I am looking at an array containing an array of arrays -- SolutionArray(u)(v)(w). I am sure that that can be improved, but I didn't know how to use arrays in anyway like this manner until I gave it a shot.

We have a full month to work on this, so the best effort will show some nice progress.

_________________
Bye,
Jay


[ This Message was edited by: Jay Petrulis on 2002-08-02 21:08 ]

[Chris Davison]

how many answers are there ?

I got one set in about 3 mins running time if it's any help...

680.23
98.40
444.98
324.84
978.53
911.45
409.17
718.32

just a very basic brute-force but random method.... I'll keep tinkering

[ This Message was edited by: Chris Davison on 2002-08-03 01:04 ]

[Chris Davison]

OOoo, and another

895.39
83.06
507.08
230.72
911.45
329.17
673.47
228.31
698.27

[Chris Davison]

192.65
194.58
444.98
630.92
978.53
144.77
329.17
116.14
718.32
441.43
365.43

[Chris Davison]

764.18
673.47
228.31
185.58
925.39
722.73
691.83
365.43

[Jack in the UK]

Hi Guys as you know i work in Finanace 15 yers and Debt Recovery / County Courts and all the rest in my times.

I feel this challenge is a poser, but underline TOTALLY pointless in the cut and thrust on debt, all invoices are debt untill PAID.

You can never work out what invoices someone will pay in advance its not like that as one bill can be in dispute or not POD fully 1000000 reasons all different or the old i ant goona pay that one till next week, thats where credit contrl comes in of cause.

In the UK this challenge is i feel against English law, that is as the idea is to work out and prepair people to pay with an system to work out what they wil pay,

ALL camoants in sales offer terms of payment credit if you like if 1 day COD or 30/ 60 days whatever, so this is the cut line, but remember guys pay in advance so that will make any system fail again

Ledgers that are cleaverly constructed are able to highlight debt and expected payments no VBA will run to give the correct results as the payer will throw a spanner in the works evertime and you time and effort will never help, on spent time re working the results.

Finance and debt is risk related so look and new debts and thats what yo need to collect matters not if or how

say i need £100

Bill should pay £60
Juan should pay £14
Jack should pay £16
Dave Should pay £30

Im £20 over but credit management hows i need only £100 the £20 in this case is cream

But say i get Chris to pay £50 i do not need Daveand Jack to pay.

So prepairing data is not workable: Debt is collected in terms and out and deals on debts also so thats the wild card

Only advice i can give is stick to law, and help you debtors and encourage them to pay, polit and friendly is best nOT hostile.

I collect £1,000,000 or $1,555,000 so my debt reduces that a top heavy collection ie im doing myself out of a job!!! i collect to much, as stastics say - so i do an ok job each month 30 day cycles.

What would do the best to answer this would be ODBC all debts in invoice format attached required details and then auto mate in letter and reports production, ie send letter or call debtor

No waht you need to do is report this debt so that you know each day what overdue and you have attacked it, now run that week and then months cross check unpaid to paid to give you collect rate % 60 to 68% is in the zone, or more that current debts occured.

Then you will have your answers.

NEVER will 100% be collected unless very few debtors to collect from i have thousands each month, i know most of them thou:

Also in letters you can trans ISO detail [invoice details] to be fired into letters...