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/viewtopic.php?topic=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
