Function for finding all combinations that sum to some value

chirp

Active Member
Joined
Nov 17, 2011
Messages
338
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 doAdd(1 To maxRec)
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)

'1 = check, add, recurse
'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
recNum = 0: Erase doAdd
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
'these additional loop checks add considerable time, but are valuable
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
    
    '1 = check, add, recurse
    '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
                    'adds to row array
                    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
                'adds to row array
                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
                    'adds to row array
                    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
        'adds unique to array
        tDic.Item(tArr) = Empty
        lastVal = tArr
    End If
skipAdd:
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 firstAdd As Long, incAdd As Long, uBnd As Long
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
firstAdd = expectedSize
If incrementalAdd < 1 Then Exit Function
incAdd = incrementalAdd

'redim temparray to the expected size (input)
ReDim tempArray(0 To firstAdd)
uBnd = firstAdd
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
            uBnd = uBnd + incAdd
            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
 

Some videos you may like

Excel Facts

Who is Mr Spreadsheet?
Author John Walkenbach was Mr Spreadsheet until his retirement in June 2019.

chirp

Active Member
Joined
Nov 17, 2011
Messages
338
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

Set ws = ThisWorkbook.Worksheets.Add
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
 

Watch MrExcel Video

Forum statistics

Threads
1,128,022
Messages
5,628,186
Members
416,299
Latest member
arunvistas

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.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

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

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

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
Top