# Function for finding all combinations that sum to some value

#### chirp

##### Active Member
just making a new thread from here just because there was a large amount of text in some posts that was annoying to load.

motivation for making this was that of the solutions readily available online i found that none were as efficient as they could be...that is not to say that this is even close to the most efficient way, and i really would like if people pointed out ways to improve it.

also this does not support negative values. it sorts descending, while i think the fastest way to do negatives is to sort ascending...so an entirely different approach (well not entirely but a few changes)

when this is stripped down of any options it improves in speed by quite a bit, but by the time speed becomes an issue there is no real practical application that i can think of...

the structure is largely based off of this method

this is likely imperfect and the completeness of any solution set could be questionable.

one last note is that this method is almost NEVER the solution to any PRACTICAL problem

okay so here are 5 sets of code, each should be placed in a separate module.

general notes on running this:

-i have not added an estimated time function, however in general the function operates at around 1million iterations/second, and you can control the max number of iterations, so 1billion max loops=~1000 seconds=~20 minutes

-i am not sure if you are familiar with vba but there is no user interface...you have to change any settings in the VBE

-you can control a) number of solutions, b) number of maximum loops, c) maximum number of elements in a solution (max recursion)

-if you specify a maximum recursion of 7, all solutions of length 7 and less will be returned, if you set "includeAll" to false, then only solutions of length 7 will be included

-if you include a variable in the "returnNumLoops" parameter, it will be returned with the value of the total number of calls to the recursive function
this slows down operation a little

-you can specify to return just the indexes, which returns the indexes of a sorted reversed list of your target values

-if you leave both numSolutions and maxLoops blank, the function will run till 100billion loops (or probably some memory limit before)

-this program usually causes excel to become unresponsive (ctrl break does not work) i dont know how to fix this, but it is important then to limit max loop number

-the maximum reasonably use for this is a random 200 number data set with a target value of about the maximum within that set.

-for number sets less than 200 the maximum reasonable target value increases gradually

Specific notes:

-i dont know how many solutions there are in your data set...i stopped at around 15000

-specifically i believe that the computation time to find all solutions is enormous

-start with small iteration numbers and increase slowly to get an idea of how long it will take (very very long)

-this is not an ideal, or even close to ideal solution for your problem, as the number of solutions is very high, and the solutions shown only represent a portion of the total set

-obviously the largest 3 numbers must appear in your sum, but other than that, this method cannot say

so easiest way is to create 5 modules than just copy paste each one of these into a separate one

main function

Code:
``````Option Explicit
Option Base 0

'arrays
Private solutionArray() As Variant, rowArr() As Long, finalDataArray() As Double
Private doWhat() As Long

'longs, counters and index
Private numSolutions As Long, solutionCount As Long, uBoundSolution As Long, recNum As Long
Private maxRec As Long, arraySizeJump As Long, lBnd As Long, uBnd As Long, savedUbound As Long
'doubles used for holding running total
Private GoalTotal As Double, allowableDiff As Double, mLoops As Double

'some booleans used to set/test for constant parameters
Private exitRecursion As Boolean, retJustNdx As Boolean, doLoop As Boolean

'returns combinations that match the goalTot of an all positive data set
'the default allowable difference should remain set at some non-zero small number (not beyond double accuracy)
'if allowableDIff is set to exactly 0 there is a significant performance hit
'the maximum number of loops corresponds to roughly a full day if constant speed, but likely
'hit other constraints first (array size?)
Public Function getAllMatchComb(goalTot As Double, _
dataArray As Variant, _
Optional numSolution As Long = 0, _
Optional maxRecursion As Long = -1, _
Optional includeAll As Boolean = True, _
Optional maxLoops As Variant, _
Optional returnNumLoops As Variant, _
Optional returnJustIndex As Boolean = False, _
Optional onlyUniqueSolutions As Boolean = True, _
Optional allowableDifference As Double = 0.000000001, _
Optional resizeSolutionJump As Long = 5000) _
As Variant

Dim arraySize As Long, I As Long, maxFirst As Long, minRecursion As Long
Dim funcTst As Boolean
Dim tstMatch As Variant, tArr As Variant
Dim tmpSUM As Double, returnLoop As Double

On Error GoTo exitFunc

'checks if dataarray is array just for fun (time spent here is not going to be significant)
If Not isArray(dataArray) Then GoTo exitFunc
'checks that redimension is >0
If resizeSolutionJump < 1 Then GoTo exitFunc

'sets inputs to module level variables
numSolutions = numSolution
GoalTotal = goalTot
arraySizeJump = resizeSolutionJump
allowableDiff = allowableDifference
retJustNdx = returnJustIndex

'gets maxloop number from input (default 100 billion---30 hours ish (think would slow down though))
If Not IsMissing(maxLoops) Then
If isNumber(maxLoops) Then
mLoops = maxLoops
Else: GoTo exitFunc
End If
Else
mLoops = 100000000000#
End If

'this is a bit messy and confusing when calling...essentially you want to count loops either
'when you want to return the num loops, or exit after..
doLoop = Not IsMissing(returnNumLoops) Or Not IsMissing(maxLoops)

'//Return a one dimensioned Array
'ensure input is one dimension (not just one dim, but also any entries that are
'arrays are "straightened out", this is an easy (probably not fastest) way of converting
'variant arrays from ranges to simple one dim arrays, order here does not matter

'****always returns a 0 based array*****
tArr = getOneDimArray(dataArray, , , funcTst)
If Not funcTst Then GoTo exitFunc
'****here after assume array is 0 based****

'get bounds of input
lBnd = LBound(tArr) 'will be 0
uBnd = UBound(tArr)

'//Sort Array
'sorts the input array
Call QSortE(tArr, , funcTst)
If Not funcTst Then GoTo exitFunc

'//Checks a few parameters to see if valid input
If hasNegatives(tArr, funcTst) Then
'exits here as a seperate method should be used with negatives
'namely an ascending sort, and getting out of the entire recursion level
'when exceeding the goal total
GoTo exitFunc
ElseIf Not funcTst Then
GoTo exitFunc
End If

'//removes any values greater than the goal total
With WorksheetFunction
'gets the index of the last entry less then or equal to the search total
'tarr is sorted ascending at this point
On Error Resume Next
tstMatch = .Match(goalTot, tArr, 1)
On Error GoTo exitFunc

'if no error then resize array to exclude values larger than the target
If Err.Number = 0 Then
uBnd = tstMatch - 1
ReDim Preserve tArr(lBnd To uBnd)
End If

'if total sum of entries is less then total exit
If .Sum(tArr) < goalTot Then GoTo exitFunc
'exits if goal total is less then smallest entry in list
If goalTot < .Min(tArr) Then GoTo exitFunc
End With

'//ReFormat array
'reverses array and removes blanks and 0's
tArr = revArrayN(delFromArraySmall(tArr, Array(0)), True)

'gets final array size
uBnd = UBound(tArr)
lBnd = LBound(tArr) 'shouldnt have changed but just in case
arraySize = getArraySize(tArr)

'exits if not enough elements
If arraySize < 3 Then GoTo exitFunc

'//Gets the minimum recursion level
Do While tmpSUM < goalTot And minRecursion <= uBnd
tmpSUM = tmpSUM + tArr(lBnd + minRecursion)
minRecursion = minRecursion + 1
Loop

tmpSUM = 0

'//Gets max elements per solution, as well as the Max index of the first recursion level
'This iterates from the smallest to largest in the array, finding the maximum
'number of elements that could possibly make up a solution
Do While tmpSUM <= goalTot And I <= uBnd
tmpSUM = tmpSUM + tArr(uBnd - I)
I = I + 1
Loop

'scale i back to reflect true max valid recursion level
I = I - 1

If maxRecursion < 1 Then
maxRec = I                      'relative to 1 base
maxFirst = arraySize - I - 1    'relative to 0 base
ElseIf maxRecursion < I Then
I = 0
'this gets the maximum point at which the n element set of contigious values falls
'below the goal total
Do While sumPart(tArr, lBnd + I, I + lBnd + maxRecursion - 1) >= goalTot
If I + lBnd + maxRecursion - 1 > uBnd Then Exit Do
I = I + 1
Loop

maxRec = maxRecursion           'relative to 1 base
maxFirst = I - 1                'relative to 0 base
Else: Exit Function    'this means no matches
End If

'sets the bounds of the final solution array
If numSolutions > 0 Then
uBoundSolution = numSolutions
Else: uBoundSolution = uBnd * uBnd * uBnd 'this term is arbitrary, ubnd^3 just so it scales a bit with size of search
End If

'//sets the dimensions of a few arrays used for results
'sets the bounds for the array to hold solutions 1 at a time
ReDim rowArr(1 To maxRec)
ReDim solutionArray(1 To uBoundSolution)
ReDim finalDataArray(lBnd To uBnd)
ReDim uBndArr(1 To maxRec)
ReDim doWhat(1 To maxRec)

'//this is a very important loop...dictates the behaviour of each recursion level
'this is not the fastest way to do it, but is the most intuitive
'populates doWhat array (boolean)

'2 = dont check, dont add, recurse
'3 = check, dont add, recurse
'4 = check, add, dont recurse

For I = 1 To maxRec
If I < minRecursion Then
doWhat(I) = 2
ElseIf I < maxRec Then
If includeAll Then
doWhat(I) = 1
Else
doWhat(I) = 3
End If
Else
doWhat(I) = 4
End If
Next

'populates final array (double)
For I = lBnd To uBnd
finalDataArray(I) = CDbl(tArr(I))
Next

'sets ubound to the initial value of maxFirst
savedUbound = uBnd
uBnd = maxFirst

'**************************************************
'**************************************************
Call matchRecurse(lBnd, 0, returnLoop) 'call actual function
'**************************************************
'**************************************************

'redim or erase array
If solutionCount > 0 Then
ReDim Preserve solutionArray(1 To solutionCount)

'return solutions
If Not retJustNdx Then
If onlyUniqueSolutions Then solutionArray = getUniqueArrayA(solutionArray)
End If

'returns solutions
getAllMatchComb = solutionArray
Else
'no solutions so exit
Erase solutionArray
End If

exitFunc:
'sets returnnumloops to returned val...still want to know loops if no solutions/error
On Error Resume Next
returnNumLoops = returnLoop

'reset some global variables
allowableDiff = 0: uBoundSolution = 0
solutionCount = 0: maxRec = 0
exitRecursion = False: mLoops = 0
Erase rowArr: uBnd = 0
Erase solutionArray: lBnd = 0

End Function

Private Function matchRecurse(curInd As Long, _
curTotal As Double, _
loopCnt As Double)

Dim tempTotal As Double, testDub As Double
Dim I As Long, tmpDoWhat As Long

'increment the recursion number each call
recNum = recNum + 1

'not sure how to do this faster
If recNum <> 1 Then uBnd = savedUbound

'this loopcnt method counts the number of times matchRecurse is called
'because it will take different times to evaluate different cases, it cannot be used exactly
'to moderate time, but limiting recursion calls is a fairly safe way of keeping time under control

'checks whether to keep track of loops
If doLoop Then
loopCnt = loopCnt + 1

If loopCnt > mLoops Then
exitRecursion = True
Exit Function
End If
End If

'gets the "doWhat" for the current recNum
tmpDoWhat = doWhat(recNum)

'loop through from input to upperbound
For I = curInd To uBnd

'2 = dont check, dont add, recurse
'3 = check, dont add, recurse
'4 = check, add, dont recurse

If tmpDoWhat < 2 Then
'set a variable to the current running total
tempTotal = curTotal + finalDataArray(I)
'gets the difference between the running total and the goal total
testDub = tempTotal - GoalTotal
If testDub < -allowableDiff Then
If I < uBnd Then
rowArr(recNum) = I - lBnd + 1 'row arr keeps track from 1..up, whereas all else is 0 based
'calls itself
Call matchRecurse(I + 1, tempTotal, loopCnt)
If exitRecursion Then Exit Function
Else: GoTo skipChecks
End If
ElseIf testDub > allowableDiff Then
GoTo skipChecks
Else
'sets the row array to the current row
rowArr(recNum) = I - lBnd + 1

'increments the solution count then adds to the solutionarray
'if the solution count exceeds the array size than the array is redimensioned
'this is expensive so arraySizeJump is good to be large
solutionCount = solutionCount + 1

'checks to redim
If solutionCount > uBoundSolution Then
ReDim Preserve solutionArray(1 To uBoundSolution + arraySizeJump)
uBoundSolution = uBoundSolution + arraySizeJump
End If
Dim l

If Not retJustNdx Then
solutionArray(solutionCount) = getStrSol
Else
solutionArray(solutionCount) = redimPreserveN(rowArr, 1, recNum)
End If

'decides if exit
If numSolutions <> solutionCount Then
GoTo skipChecks
Else
exitRecursion = True
Exit Function
End If
End If
ElseIf tmpDoWhat < 3 Then
If I < uBnd Then
rowArr(recNum) = I - lBnd + 1 'row arr keeps track from 1..up, whereas all else is 0 based
'calls itself
Call matchRecurse(I + 1, curTotal + finalDataArray(I), loopCnt)
If exitRecursion Then Exit Function
End If
ElseIf tmpDoWhat < 4 Then
'set a variable to the current running total
tempTotal = curTotal + finalDataArray(I)
'gets the difference between the running total and the goal total
If tempTotal - GoalTotal < -allowableDiff Then
If I < uBnd Then
rowArr(recNum) = I - lBnd + 1 'row arr keeps track from 1..up, whereas all else is 0 based
'calls itself
Call matchRecurse(I + 1, tempTotal, loopCnt)
If exitRecursion Then Exit Function
Else: GoTo skipChecks
End If
End If
ElseIf Abs(GoalTotal - (curTotal + finalDataArray(I))) <= allowableDiff Then
'sets the row array to the current row
rowArr(recNum) = I - lBnd + 1

'increments the solution count then adds to the solutionarray
'if the solution count exceeds the array size than the array is redimensioned
'this is expensive so arraySizeJump is good to be large
solutionCount = solutionCount + 1

'checks to redim
If solutionCount > uBoundSolution Then
ReDim Preserve solutionArray(1 To uBoundSolution + arraySizeJump)
uBoundSolution = uBoundSolution + arraySizeJump
End If

If Not retJustNdx Then
solutionArray(solutionCount) = getStrSol
Else
solutionArray(solutionCount) = redimPreserveN(rowArr, 1, recNum)
End If

'decides if exit
If numSolutions <> solutionCount Then
GoTo skipChecks
Else
exitRecursion = True
Exit Function
End If
End If
skipChecks:
Next

'delete entry in rowarr
rowArr(recNum) = 0

'decrement recursion number
recNum = recNum - 1

End Function

'no real error checking here...
Private Function getStrSol() As String
Dim tVar

For Each tVar In redimPreserveN(rowArr, 1, recNum)
getStrSol = getStrSol & "+" & finalDataArray(tVar - 1 + lBnd)
Next
End Function``````

this is a function used to test/call
Code:
``````Option Explicit
Option Base 0

Sub testFunctions()
Dim dic As Object
Dim dt As Date

Dim v, v1, V2
Dim dub As Double
Dim I As Long

'for test funtion operation
Dim timSum() As Double
Dim tim As Double
Dim j As Long, trialName As String

'***********************CHECK THESE BEFORE RUNNING ***************************
Const numTrials As Long = 10
Const numSubTrials As Long = 1
Const printResult As Boolean = True
trialName = "Test combo finder:"
ReDim timSum(1 To numTrials)
'***********************CHECK THESE BEFORE RUNNING ***************************

'moves a range to a variant array
v = Selection.Value2

For j = 1 To numTrials
tim = microTimer
For I = 1 To numSubTrials
dub = 0
'call function here!!!
v1 = getAllMatchComb(100, v)
Next
timSum(j) = microTimer - tim
Next

'this doesnt print the array, just info about the total time
If printResult Then
With WorksheetFunction
Debug.Print Chr(13) & trialName & Chr(13) & "Total time: " & .Sum(timSum) & Chr(13) & "Average: " & .Average(timSum) & Chr(13) & "Max: " & .Max(timSum) _
& Chr(13) & "Min :" & .Min(timSum) & Chr(13) & "Number of loops: " & dub
On Error Resume Next
Debug.Print "Standard Deviation: " & .StDev(timSum) & Chr(13)
End With
End If

'the resulting array v1...you can do whatever with here
Stop

Set dic = Nothing
End Sub``````

some functions used by the procedure...some are not really to robust
Code:
``````Option Explicit
Option Base 0

'windows api call

Public Declare Function getFrequency Lib "kernel32" _
Alias "QueryPerformanceFrequency" (cyFrequency As Currency) As Long

Public Declare Function getTickCount Lib "kernel32" _
Alias "QueryPerformanceCounter" (cyTickCount As Currency) As Long

'from msdn
Function microTimer() As Double
Dim cyTicks1 As Currency
Static cyFrequency As Currency

microTimer = 0
' Get frequency.
If cyFrequency = 0 Then getFrequency cyFrequency
' Get ticks.
getTickCount cyTicks1
' Seconds
If cyFrequency Then microTimer = cyTicks1 / cyFrequency
End Function

'returns a unique array from an array using dictionary
Public Function getUniqueArrayA(inputArray, _
Optional skipBlanks As Boolean = False, _
Optional matchCase As Boolean = True, _
Optional tst As Boolean) As Variant

Dim tDic As Object
Dim tArr As Variant, lastVal As Variant

tst = False
On Error GoTo exitFunc
'checks if input is array or range, exits if else
Select Case TypeName(inputArray)
Case "Variant()"
Case "Range"
inputArray = inputArray
Case Else
Exit Function
End Select

'sets dictionary
Set tDic = CreateObject("scripting.dictionary")
If matchCase Then tDic.CompareMode = vbTextCompare

'loops through array
For Each tArr In inputArray
'skips blanks if told
If skipBlanks Then
If tArr = vbNullString Then GoTo skipAdd
End If

'shortcut if sorted or partially sorted
If tArr <> lastVal Then
tDic.Item(tArr) = Empty
lastVal = tArr
End If
Next

'return array
getUniqueArrayA = tDic.Keys

tst = True
exitFunc:
Set tDic = Nothing
End Function

'lets you use redim preserve on one line
'no error check just exits
Public Function redimPreserveN(ByVal arr, lBnd As Long, uBnd As Long, _
Optional tst As Boolean) As Variant
tst = False
On Error GoTo exitFunc
ReDim Preserve arr(lBnd To uBnd)
redimPreserveN = arr
tst = True
exitFunc:
End Function

'checks if an array has any negative values

Public Function hasNegatives(arr, Optional tst As Boolean) As Boolean
Dim tVar As Variant

tst = False
On Error GoTo exitFunc
If Not isArray(arr) Then Exit Function

For Each tVar In arr
If tVar < 0 Then
tst = True
hasNegatives = True
Exit Function
End If
Next

tst = True
exitFunc:
End Function

'simple takes an array and reverses it, copys, requires array mem*2
Public Function revArrayN(arr, _
Optional skipBlanks As Boolean = False, _
Optional tst As Boolean) As Variant()
Dim tVar, tArr
Dim I As Long

tst = False
On Error GoTo exitFunc

If Not isArray(arr) Then Exit Function

I = UBound(arr)
ReDim tArr(LBound(arr) To I)

For Each tVar In arr
If skipBlanks Then If tVar = vbNullString Then GoTo nxt
tArr(I) = tVar
I = I - 1
nxt:
Next

revArrayN = tArr
tst = True
exitFunc:
End Function

Public Function getArraySize(testArray, _
Optional testDim As Long = 1, _
Optional tst As Boolean) As Long
tst = False
On Error GoTo exitFunc
getArraySize = UBound(testArray, testDim) - LBound(testArray, testDim) + 1
tst = True
exitFunc:
End Function

'sums part of an array
'does not have good error checking
Public Function sumPart(arr, ind1 As Long, ind2 As Long, _
Optional tst As Boolean) As Double

Dim I As Long
Dim mn As Double, mx As Double

If Not isArray(arr) Then Exit Function
If mn < LBound(arr) Then Exit Function
If mx > UBound(arr) Then Exit Function

mn = rMin(ind1, ind2)
mx = rMax(ind1, ind2)

On Error Resume Next
For I = mn To mx
If isNumber(arr(I)) Then sumPart = sumPart + arr(I)
Next

tst = Err.Number = 0

End Function

'faster than worksheet function for individually entered numbers ie paramarray=1,3,5,6,4,2
Public Function rMax(ParamArray testNums() As Variant) As Double
Dim tVar, notFirst As Boolean

On Error Resume Next
For Each tVar In testNums
If Not isNumber(tVar) Then GoTo nxt
If notFirst Then
If tVar > rMax Then rMax = tVar
Else
rMax = tVar
notFirst = True
End If
nxt:
Next

End Function

'faster than worksheet function for individually entered numbers ie paramarray=1,3,5,6,4,2
Public Function rMin(ParamArray testNums() As Variant) As Double
Dim tVar, notFirst As Boolean

On Error Resume Next
For Each tVar In testNums
If Not isNumber(tVar) Then GoTo nxt
If notFirst Then
If tVar < rMin Then rMin = tVar
Else
rMin = tVar
notFirst = True
End If
nxt:
Next

End Function

Public Function isNumber(testVar, _
Optional trueIfConvertable As Boolean = False) As Boolean

On Error GoTo exitFunc
Select Case VarType(testVar)
Case 2 To 7, 14
isNumber = True
Case 8
If trueIfConvertable Then
If IsNumeric(testVar) Then isNumber = True
End If
End Select

exitFunc:
End Function

Public Function isOneDim(testArray) As Boolean
Dim Result As Long
On Error Resume Next
Result = LBound(testArray, 2)
isOneDim = Err.Number <> 0
End Function

'tests if array is initialized by tring to assign a value to its Ubnd
Public Function isArrayInitialized(testArray) As Boolean

Dim testLng As Long
On Error Resume Next
testLng = UBound(testArray)
isArrayInitialized = Err.Number = 0
End Function

'returns a 0 dimensioned array
Public Function delFromArraySmall(arr, deleteThis, _
Optional matchCase As Boolean = True, _
Optional tst As Boolean) As Variant()

Dim tVar As Variant, tTst As Variant
Dim storeArr As Variant, cnt As Long
Dim isArr As Boolean

tst = False
On Error GoTo exitFunc

'ensures input is array
If isArray(deleteThis) Then isArr = True

'crestes an array to hold "non-deleted" items
ReDim storeArr(0 To UBound(arr) - LBound(arr))

'loops through skips over any matches...not best way of doing this
For Each tVar In arr
If isArr Then
For Each tTst In deleteThis
If matchCase Then
If tVar = tTst Then GoTo nxt
ElseIf UCase(tVar) = UCase(tTst) Then GoTo nxt
End If
Next
Else
If matchCase Then
If tVar = deleteThis Then GoTo nxt
Else: If UCase(tVar) = UCase(tTst) Then GoTo nxt
End If
End If

'makes it here than not in array...should really clean this function up
storeArr(cnt) = tVar
cnt = cnt + 1
nxt:
Next

ReDim Preserve storeArr(0 To cnt - 1)
delFromArraySmall = storeArr

tst = True
exitFunc:
End Function``````

this just gets a one dimensional "version" of a jagged/multidim array
Code:
``````Option Explicit
Option Base 0

Private tempArray As Variant
Private cnt As Long

Public Function getOneDimArray(inputVar, _
Optional expectedSize As Long = 5000, _
Optional incrementalAdd As Long = 1000, _
Optional tst As Boolean _
) As Variant()
Dim tmpArr As Variant

tst = False
On Error GoTo exitFunc
'set global variables to input
If expectedSize < 1 Then Exit Function
If incrementalAdd < 1 Then Exit Function

'redim temparray to the expected size (input)
cnt = 0: uBnd = 0

'actually call function
Call recurseOneDim(inputVar)

If cnt > 0 Then
ReDim Preserve tempArray(0 To cnt - 1)
getOneDimArray = tempArray
tst = True
End If

exitFunc:
End Function

'simple recursive function to "straighten out" any variant array
'very slow should be used only in specific circumstances
'will not currently work with objects etc...easily adapted
Private Function recurseOneDim(testArray)

Dim tVal As Variant

On Error GoTo exitFunc

For Each tVal In testArray
If Not isArray(tVal) Then
If cnt > uBnd Then
ReDim Preserve tempArray(0 To uBnd)
End If

tempArray(cnt) = tVal
cnt = cnt + 1
Else
Call recurseOneDim(tVal)
End If
Next

exitFunc:
End Function``````

simple qSort
Code:
``````Option Explicit
Option Base 0

Private arrayType As Long
Private compareMeth As VbCompareMethod

'simple qSort...picks the pivot at halfway point...
Private Function recurseSort(vArray As Variant, _
inLow As Long, _
inHi As Long)

Dim tmpLow As Long
Dim tmpHi As Long
Dim tmpSwap As Variant
Dim pivot As Variant

On Error GoTo exitFunc
tmpLow = inLow
tmpHi = inHi

pivot = vArray((inLow + inHi) \ 2)

Do While (tmpLow <= tmpHi)
Select Case arrayType
Case 2 To 7, 12, 14, 17
Do
If vArray(tmpLow) >= pivot Then Exit Do
If tmpLow >= inHi Then Exit Do
tmpLow = tmpLow + 1
Loop

Do
If pivot >= vArray(tmpHi) Then Exit Do
If tmpHi <= inLow Then Exit Do
tmpHi = tmpHi - 1
Loop
Case 8
Do
If StrComp(vArray(tmpLow), pivot, compareMeth) <> -1 Then Exit Do
If tmpLow >= inHi Then Exit Do
tmpLow = tmpLow + 1
Loop

Do
If StrComp(vArray(tmpLow), pivot, compareMeth) = -1 Then Exit Do
If tmpHi <= inLow Then Exit Do
tmpHi = tmpHi - 1
Loop
Case Else
'other data types not supported
Exit Function
End Select

If (tmpLow <= tmpHi) Then
tmpSwap = vArray(tmpLow)
vArray(tmpLow) = vArray(tmpHi)
vArray(tmpHi) = tmpSwap
tmpLow = tmpLow + 1
tmpHi = tmpHi - 1
End If
Loop

If (inLow < tmpHi) Then recurseSort vArray, inLow, tmpHi
If (tmpLow < inHi) Then recurseSort vArray, tmpLow, inHi

exitFunc:
End Function

Public Function QSortE(vArray As Variant, _
Optional strCompareMode As VbCompareMethod = vbBinaryCompare, _
Optional tst As Boolean)

tst = False
On Error GoTo exitFunc
If Not isArray(vArray) Then Exit Function
arrayType = VarType(vArray) - 8192
compareMeth = strCompareMode
Call recurseSort(vArray, LBound(vArray), UBound(vArray))

tst = True

exitFunc:
arrayType = 0
End Function

'simple qSort...picks the pivot at halfway point...

Public Function QSortN(ByVal vArray As Variant, _
Optional strCompareMode As VbCompareMethod = vbBinaryCompare, _
Optional tst As Boolean) As Variant

tst = False
On Error GoTo exitFunc
If Not isArray(vArray) Then Exit Function
arrayType = VarType(vArray) - 8192
compareMeth = strCompareMode
Call recurseSort(vArray, LBound(vArray), UBound(vArray))
QSortN = vArray
tst = True

exitFunc:
arrayType = 0: pivot = Empty
tmpSwap = Empty
End Function``````

### Excel Facts

Highlight Duplicates
Home, Conditional Formatting, Highlight Cells, Duplicate records, OK to add pink formatting to any duplicates in selected range.

#### chirp

##### Active Member
for a simple way of inputting basic parameters...will output to a new sheet a maximum of the number of rows...shouldnt be too much of a problem if using 2007 and up

(replace the original "test" module)
Code:
``````Option Explicit
Option Base 0

Sub getCombinations()
Dim dic As Object
Dim dt As Date

Dim v, v1, v2
Dim dub As Double, sumGoal As Double, maxLoopNum As Double
Dim I As Long, rowCnt As Long

'for test funtion operation
Dim timSum() As Double
Dim tim As Double
Dim j As Long, trialName As String
Dim ws As Worksheet

'***********************CHECK THESE BEFORE RUNNING ***************************
Const numTrials As Long = 1
Const numSubTrials As Long = 1
Const printResult As Boolean = True
trialName = "Test combo finder"
ReDim timSum(1 To numTrials)
'***********************CHECK THESE BEFORE RUNNING ***************************
On Error GoTo exitFunc

v = Application.InputBox("Enter data range:", "Get Data Range", , , , , , 8).Value2
sumGoal = Application.InputBox("Input goal total:", "Goal Total", , , , , , 1)
maxLoopNum = Application.InputBox("Input the estimated number of minutes you want to run the function for:", , , , , , 1) * 60000000

For j = 1 To numTrials
tim = microTimer
For I = 1 To numSubTrials
dub = 0
'call function here!!!
v1 = getAllMatchComb(sumGoal, v, , , , maxLoopNum)
Next
timSum(j) = microTimer - tim
Next

'this doesnt print the array, just info about the total time
If printResult Then
With WorksheetFunction
Debug.Print Chr(13) & trialName & Chr(13) & "Total time: " & .Sum(timSum) & Chr(13) & "Average: " & .Average(timSum) & Chr(13) & "Max: " & .Max(timSum) _
& Chr(13) & "Min :" & .Min(timSum) & Chr(13) & "Number of loops: " & dub
On Error Resume Next
Debug.Print "Standard Deviation: " & .StDev(timSum) & Chr(13)
End With
End If

ReDim v(LBound(v1) To UBound(v1), 1 To 1)
For I = LBound(v1) To UBound(v1)
v(I, 1) = v1(I)
Next

With ws
If getArraySize(v) > .Rows.Count Then
.Range("a1").Resize(.Rows.Count) = v
Else
.Range("a1").Resize(getArraySize(v)) = v
End If
End With

exitFunc:

Set dic = Nothing
End Sub``````

Replies
5
Views
540
Replies
3
Views
357
Replies
0
Views
259
Replies
27
Views
313
Replies
36
Views
944

1,127,787
Messages
5,626,876
Members
416,208
Latest member
tan21

### We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.

### Which adblocker are you using?

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

### Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

### Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back