Function for finding all combinations that sum to some value

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

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

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

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

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