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

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

_________________

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 ]

## Like this thread? Share it with others