Option Explicit
Option Base 0
'VArs for main search
Dim modRowArr() As Long, modDataArray() As Double, modDoWhat() As Long
'longs, counters and index
Dim modNumSol As Long, modSolCount As Long, modRecNum As Long
Dim modMaxRec As Long, moduBnd As Long, modUBnd2 As Long
'doubles used for holding running total
Dim modGoalTot As Double, modAllDiff As Double, modMaxLoops As Double, modMinVal As Double, modLoopCnt As Double
Dim modSolDic As Object
'some booleans used to set/test for constant parameters
Dim modExRec As Boolean, modRetNdx As Boolean, modDoLoop As Boolean, modChangeBound As Boolean
'vars for redim
Dim modTempArray As Variant
Dim modIncAdd As Long, modUBnd3 As Long, modCnt As Long
'used in a few range functions
Public Enum cornerCell
leftTop = 0
rightTop = 1
leftBottom = 2
rightBottom = 3
End Enum
'*****************************************************************************
'*****************************************************************************
'*****************************************************************************
'Parameters:
'goalTotal: A positive double precision number that you want to match
'dataArray: An array of values that are possible in the desired combinations
'numSolution: Max number of solutions (default=0 gets all)
'MaxRecursion: Maximum number of entries in one combination (default=-1 no limit)
'IncludeAll: If a maximum recursion is specified include all specifies whether
' to return combinations of just that length, or any of less length as well
'MaxLoops: Can set the max number of total loops
'ReturnNumLoops: Passed by reference, holds the value of the number of loops after function runs
'ReturnJustIndex: This returns just the index of the combinations
'AllowableDIff: the allowable difference. due to floating point comparison must be some small number
'should be >~1e-10
Sub FindCombinations()
Dim v, r As Range, r1 As Range, inTar, tim As Double
'return all solutions
On Error Resume Next
Set r = Application.InputBox("Select data set.", "Find Combinations", "=" & Selection.Address, , , , , 8)
If Not r Is Nothing Then
Set r1 = Application.InputBox("Select starting cell of output", "Find Combination", "=" & r.Cells(1).Offset(0, 1).Address, , , , , 8).Cells(1)
If Not r1 Is Nothing Then
inTar = InputBox("Enter search total", "Find Combination")
If IsNumeric(inTar) Then
tim = microTimer
v = getAllMatchComb(CDbl(inTar), rUsedrange(r).Value2, , 4, False)
'pastes onto sheet
r1 = "Range: " & r.Address & "; Target: " & inTar & "; Time: " & Round(microTimer - tim, 3) & "; Count: " & getArraySize(v)
If Not IsEmpty(v) Then Call doPrint1D(v, r1.Offset(1))
End If
End If
End If
End Sub
'*****************************************************************************
'*****************************************************************************
'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---ie run out of stack space as this is a recursive function
Public Function getAllMatchComb(goalTotal As Double, _
ByVal 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 allowableDifference As Double = 0.000000001) _
As Variant
Dim arraySize As Long, i As Long, minRecursion As Long, cnt As Long
Dim ind1 As Long, ind2 As Long
Dim funcTst As Boolean
Dim tVar As Variant
Dim sumNegs As Double, sumPos As Double, tmpSum As Double
On Error GoTo exitFunc
'//Checks simple inputs are valid
If Not IsArray(dataArray) Then GoTo exitFunc
If Not goalTotal >= 0 Then
MsgBox "Search term must be greater or equal to 0"
GoTo exitFunc
End If
'//double checks allowable difference is reasonable
allowableDifference = Abs(allowableDifference)
If allowableDifference = 0 Then allowableDifference = 0.000000001
'//Sets inputs to module level variables
modNumSol = numSolution
modGoalTot = goalTotal
modAllDiff = allowableDifference
modRetNdx = returnJustIndex
modDoLoop = Not IsMissing(returnNumLoops) Or Not IsMissing(maxLoops)
Set modSolDic = CreateObject("scripting.dictionary")
modChangeBound = True
'//gets maxloop number from input (default 10 billion---lots of time...likely to run out of stack space first)
If Not IsMissing(maxLoops) Then
If isNumber(maxLoops, True) Then
modMaxLoops = CDbl(maxLoops)
Else: GoTo exitFunc
End If
Else
modMaxLoops = 10000000000#
End If
'//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
dataArray = arr2oneD(dataArray, , , funcTst)
If Not funcTst Then GoTo exitFunc
'****here after array is 0 based****
'//Redim final data array
ReDim modDataArray(0 To getArraySize(dataArray) - 1)
'//Remove non-numbers-input to double type array
For i = 0 To UBound(dataArray)
If isNumber(dataArray(i), True) Then
If CDbl(dataArray(i)) <> 0 Then
modDataArray(cnt) = CDbl(dataArray(i))
cnt = cnt + 1
End If
End If
Next
'//Redim array to remove excess entries
If cnt - 1 <> UBound(dataArray) Then ReDim Preserve modDataArray(0 To cnt - 1)
'//Sort Array
Call qSortd(modDataArray, funcTst)
If Not funcTst Then GoTo exitFunc
'//Gets negative sum
tVar = Application.Match(0, modDataArray)
If isNumber(tVar) Then sumNegs = Abs(sumPartD(modDataArray, 0, CLng(tVar) - 1))
'//Gets positive sum
sumPos = WorksheetFunction.Sum(modDataArray) + sumNegs
'//Removes numbers with no possibility of combination
'if num < 0: num < goalTot - allDiff - sumPos
tmpSum = modGoalTot - modAllDiff - sumPos
tVar = Application.Match(tmpSum, modDataArray)
If isNumber(tVar) Then
ind2 = UBound(modDataArray) - tVar + 1
Else: ind2 = UBound(modDataArray) + 1
End If
'//Reverse array
Call revArrayED(modDataArray, funcTst)
If Not funcTst Then GoTo exitFunc
'//Removes numbers with no possibility of combination
'if num > 0: num > goalTot + allDiff + sumNeg
tmpSum = modGoalTot + modAllDiff + sumNegs
tVar = Application.Match(tmpSum, modDataArray, -1)
If isNumber(tVar) Then
ind1 = tVar + IIf(modDataArray(tVar - 1) <> tmpSum, 1, 0)
Else: ind1 = 1
End If
'//Returns the relevant portion of the array
If ind1 <> 1 Or ind2 <> UBound(modDataArray) + 1 Then
modDataArray = getArrayPartD(modDataArray, ind1, ind2, True, funcTst)
If Not funcTst Then GoTo exitFunc
End If
'//Set final array and get attributes
moduBnd = ind2 - ind1
arraySize = moduBnd + 1
'*******************************************************************************
'//NOTE:
'At this point the modDataArray should contain a sorted,
'all numeric, data set that includes numbers in the "solution space" (shouldnt really use "space" here)
'*******************************************************************************
'//Gets the minimum recursion level
tmpSum = 0
Do
tmpSum = tmpSum + modDataArray(minRecursion)
minRecursion = minRecursion + 1
Loop While tmpSum < goalTotal And minRecursion <= moduBnd
'//Reset counter variables
tmpSum = 0: i = 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
tmpSum = tmpSum + modDataArray(moduBnd - i)
i = i + 1
Loop While tmpSum <= goalTotal And i <= moduBnd
'//uses i found for max num elements to set/confirm maxFirst
'the second part of this if structure is to ensure that any
'specifies maximum recursion is allowable
If maxRecursion < 1 Then
modMaxRec = i 'relative to 1 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 sumPartD(modDataArray, i, i + maxRecursion - 1) >= goalTotal - modAllDiff
i = i + 1
If i + maxRecursion - 1 > moduBnd Then Exit Do
Loop
modMaxRec = maxRecursion 'relative to 1 base
Else: GoTo exitFunc 'this means no matches
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 modRowArr(1 To modMaxRec)
ReDim modDoWhat(1 To modMaxRec)
'//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
For i = 1 To modMaxRec
If i < minRecursion Then
modDoWhat(i) = 2
ElseIf i < modMaxRec Then
If includeAll Then modDoWhat(i) = 1 Else modDoWhat(i) = 3
Else
modDoWhat(i) = 4
End If
Next
'//sets ubound to the initial value of maxFirst
'sets some other inital values
modUBnd2 = moduBnd - 1
modMinVal = modMinVal - modAllDiff
If sumNegs <> 0 Then
'//Reverse array
Call revArrayED(modDataArray, funcTst)
If Not funcTst Then GoTo exitFunc
'//Get position of maximum first loop
tVar = Application.Match((modGoalTot + modAllDiff), modDataArray) 'could add /2 here
'then check if actual val exists then add but would not save much time
If isNumber(tVar) Then moduBnd = tVar - 1 Else moduBnd = UBound(modDataArray)
Else
moduBnd = moduBnd - modMaxRec + 1
End If
'**************************************************
On Error Resume Next
Call matchRecurse(0, 0) 'call actual function
'**************************************************
'//redim or erase array, returns solutions
If modSolCount > 0 Then
If modRetNdx Then
getAllMatchComb = modSolDic.Items
Else
getAllMatchComb = modSolDic.Keys
End If
End If
exitFunc:
'//sets returnnumloops to returned val...still want to know loops if no solutions/error
On Error Resume Next
returnNumLoops = modLoopCnt
'//reset some module level variables
modAllDiff = 0: modRecNum = 0
modSolCount = 0: modMaxRec = 0
modExRec = False: modMaxLoops = 0
Erase modRowArr: moduBnd = 0
modMinVal = 0: modLoopCnt = 0
End Function
Private Function matchRecurse(curInd As Long, curTotal As Double)
Dim testDub As Double, tempDub As Double
Dim i As Long, tmpDoWhat As Long
'increment the recursion number each call
modRecNum = modRecNum + 1
tempDub = modGoalTot - curTotal
'not sure how to do this faster
If modChangeBound Then If modRecNum <> 1 Then moduBnd = modUBnd2: modChangeBound = False
'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 modDoLoop Then modLoopCnt = modLoopCnt + 1: If modLoopCnt > modMaxLoops Then modExRec = True: Exit Function
'gets the "doWhat" for the current recNum
tmpDoWhat = modDoWhat(modRecNum)
'loop through from input to upperbound
For i = curInd To moduBnd
'1 = check, add, recurse
'2 = dont check, dont add, recurse
'3 = check, dont add, recurse
'4 = check, add
If tmpDoWhat < 2 Then
'gets the difference between the running total and the goal total
testDub = tempDub - modDataArray(i)
If testDub > modAllDiff Then
If testDub < modMinVal Then GoTo skipChecks
'adds to row array
modRowArr(modRecNum) = i + 1 'row arr keeps track from 1..up, whereas all else is 0 based
'calls itself
Call matchRecurse(i + 1, modGoalTot - testDub)
'checks exit
If modExRec Then Exit Function
ElseIf testDub < -modAllDiff Then
GoTo skipChecks
Else
'sets the row array to the current row
modRowArr(modRecNum) = i + 1
If modRetNdx Then
'increments the solution count
modSolCount = modSolCount + 1
modSolDic.Add modSolCount, redimPreserveN(modRowArr, 1, modRecNum)
'decides if exit
If modNumSol <> modSolCount Then GoTo skipChecks
modExRec = True
Exit Function
Else
'increments the solution count
testDub = modSolDic.Count
modSolDic(getStrSol) = Empty
If testDub < modSolDic.Count Then
modSolCount = modSolCount + 1
'decides if exit
If modNumSol <> modSolCount Then GoTo skipChecks
modExRec = True
Exit Function
End If
End If
End If
ElseIf tmpDoWhat < 3 Then
'adds to row array
modRowArr(modRecNum) = i + 1 'row arr keeps track from 1..up, whereas all else is 0 based
'calls itself
Call matchRecurse(i + 1, curTotal + modDataArray(i))
'checks exit
If modExRec Then Exit Function
ElseIf tmpDoWhat < 4 Then
'gets the difference between the running total and the goal total
testDub = tempDub - modDataArray(i)
If testDub > modAllDiff Then
If testDub < modMinVal Then GoTo skipChecks
'adds to row array
modRowArr(modRecNum) = i + 1 'row arr keeps track from 1..up, whereas all else is 0 based
'calls itself
Call matchRecurse(i + 1, modGoalTot - testDub)
If modExRec Then Exit Function
End If
ElseIf Abs(tempDub - modDataArray(i)) <= modAllDiff Then
'sets the row array to the current row
modRowArr(modRecNum) = i + 1
If modRetNdx Then
'increments the solution count
modSolCount = modSolCount + 1
modSolDic.Add modSolCount, redimPreserveN(modRowArr, 1, modRecNum)
'decides if exit
If modNumSol <> modSolCount Then GoTo skipChecks
modExRec = True
Exit Function
Else
'increments the solution count
testDub = modSolDic.Count
modSolDic(getStrSol) = Empty
If testDub < modSolDic.Count Then
modSolCount = modSolCount + 1
'decides if exit
If modNumSol <> modSolCount Then GoTo skipChecks
modExRec = True
Exit Function
End If
End If
End If
skipChecks:
Next
'this just takes care of the true Ubound case
If tmpDoWhat <> 3 Then
If Abs(tempDub - modDataArray(i)) <= modAllDiff Then
'sets the row array to the current row
modRowArr(modRecNum) = i + 1
If modRetNdx Then
'increments the solution count
modSolCount = modSolCount + 1
modSolDic.Add modSolCount, redimPreserveN(modRowArr, 1, modRecNum)
'decides if exit
If modNumSol <> modSolCount Then GoTo exitIf
modExRec = True
Exit Function
Else
'increments the solution count
testDub = modSolDic.Count
modSolDic(getStrSol) = Empty
If testDub < modSolDic.Count Then
modSolCount = modSolCount + 1
'decides if exit
If modNumSol <> modSolCount Then GoTo exitIf
modExRec = True
Exit Function
End If
End If
End If
End If
exitIf:
'delete entry in modrowarr
modRowArr(modRecNum) = 0
'decrement recursion number
modRecNum = modRecNum - 1
End Function
'no real error checking here...
Private Function getStrSol() As String
Dim tVar
For Each tVar In redimPreserveN(modRowArr, 1, modRecNum)
getStrSol = getStrSol & "+" & modDataArray(tVar - 1)
Next
End Function
Public Function arr2oneD(inputVar, _
Optional expectedSize As Long = -1, _
Optional incrementalAdd As Long = -1, _
Optional tst As Boolean _
) As Variant()
Dim tmpArr As Variant
tst = False
On Error GoTo exitFunc
If Not IsArray(inputVar) Then GoTo exitFunc
'set global variables to input
If expectedSize < 1 Then expectedSize = UBound(inputVar) * 10
modUBnd3 = expectedSize
If incrementalAdd < 1 Then incrementalAdd = expectedSize / 2
modIncAdd = incrementalAdd
'redim temparray to the expected size (input)
ReDim modTempArray(0 To modUBnd3)
modCnt = 0: modUBnd3 = 0
'actually call function
Call recurseOneDim(inputVar)
If modCnt > 0 Then
ReDim Preserve modTempArray(0 To modCnt - 1)
arr2oneD = modTempArray
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 modCnt > modUBnd3 Then modUBnd3 = modUBnd3 + modIncAdd: ReDim Preserve modTempArray(0 To modUBnd3)
modTempArray(modCnt) = tVal
modCnt = modCnt + 1
Else
Call recurseOneDim(tVal)
End If
Next
exitFunc:
End Function
Public Function isArrayInitialized(testArray) As Boolean
On Error Resume Next
isArrayInitialized = UBound(testArray) - LBound(testArray) + 1
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
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
Function sumPartD(Arr() As Double, stInd As Long, endInd As Long, _
Optional tst As Boolean) As Double
Dim i As Long
tst = False
On Error GoTo exitFunc
If stInd > endInd Then GoTo exitFunc
If Not validArray(Arr) Then GoTo exitFunc
For i = stInd To endInd
sumPartD = sumPartD + Arr(i)
Next
tst = True
exitFunc:
End Function
'faster than worksheet function for individually entered numbers ie paramarray=1,3,5,,6,4,2
Function rMax(ParamArray testNums() As Variant) As Double
Dim tVar, notFirst As Boolean
On Error Resume Next
For Each tVar In testNums
If isNumber(tVar) Then If notFirst Then If tVar > rMax Then rMax = tVar Else rMax = tVar: notFirst = True
Next
End Function
'faster than worksheet function for individually entered numbers ie paramarray=1,3,5,,6,4,2
Function rMin(ParamArray testNums() As Variant) As Double
Dim tVar, notFirst As Boolean
On Error Resume Next
For Each tVar In testNums
If isNumber(tVar) Then If notFirst Then If tVar < rMin Then rMin = tVar Else rMin = tVar: notFirst = True
Next
End Function
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
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 isNumber = IsNumeric(testVar)
End Select
exitFunc:
End Function
'this just checks if the input array is initialized and matches the input dimension
'~1.15s/1000000 ---this is slow calls 2 functions within it, better to call those 2 inline
Function validArray(testArray, _
Optional checkDim As Long = 1) As Boolean
If IsArray(testArray) Then
If checkDim = 1 Then
If isArrayInitialized(testArray) Then
If isOneDim(testArray) Then validArray = True: Exit Function
End If
ElseIf checkDim > 0 Then
If isArrayInitialized(testArray) Then
If getArrayDim(testArray) = checkDim Then validArray = True: Exit Function
End If
End If
End If
End Function
'returns 0 if not initialized, dimension as a long type otherwise
'~1s/1000000
Function getArrayDim(testArray) As Long
Dim tmp As Long, i As Long
On Error Resume Next
Do
i = i + 1
tmp = LBound(testArray, i)
Loop Until Err.Number <> 0
getArrayDim = i - 1
End Function
Private Sub privateD(vArray() As Double, inLow As Long, inHI As Long)
Dim pivot As Double
Dim tmpSwap As Double
Dim tmpLow As Long
Dim tmpHi As Long
tmpLow = inLow
tmpHi = inHI
pivot = vArray((inLow + inHI) \ 2)
Do While (tmpLow <= tmpHi)
Do
If vArray(tmpLow) < pivot Then If tmpLow < inHI Then tmpLow = tmpLow + 1 Else Exit Do Else Exit Do
Loop
Do
If pivot < vArray(tmpHi) Then If tmpHi > inLow Then tmpHi = tmpHi - 1 Else Exit Do Else Exit Do
Loop
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 privateD vArray, inLow, tmpHi
If (tmpLow < inHI) Then privateD vArray, tmpLow, inHI
End Sub
Public Function qSortd(inputArray() As Double, _
Optional tst As Boolean)
tst = False
On Error GoTo exitFunc
If validArray(inputArray) Then
Call privateD(inputArray, LBound(inputArray), UBound(inputArray))
tst = True
End If
exitFunc:
End Function
'real basic should update col/row
'dont know why use this silly approach not "print" all in one shot
Sub doPrint1D(vInput, vRange As Range, _
Optional tst As Boolean)
Dim tLng As Long, vSz As Long, tRng As Range, tArr As Variant
Dim i As Long, sz As Long, doLoop As Boolean, st As Long, colOff As Long
tst = False
On Error GoTo exitFunc
If Not validArray(vInput) Then GoTo exitFunc
Set tRng = vRange.Cells(1)
tLng = Application.Rows.Count - tRng.Row + 1
vSz = getArraySize(vInput)
st = LBound(vInput)
Do
If vSz > tLng Then
ReDim tArr(1 To tLng, 1 To 1)
For i = 1 To tLng
tArr(i, 1) = vInput(st + i - 1)
Next
tRng.Offset(0, colOff).Resize(tLng) = tArr
vSz = vSz - tLng
st = st + tLng
colOff = colOff + 1
doLoop = True
Else
ReDim tArr(1 To vSz, 1 To 1)
For i = 1 To vSz
tArr(i, 1) = vInput(st + i - 1)
Next
tRng.Offset(0, colOff).Resize(vSz) = tArr
doLoop = False
End If
Loop While doLoop
tst = True
exitFunc:
End Sub
'reverses in place, does not copy, saves memory
Sub revArrayED(Arr() As Double, _
Optional tst As Boolean)
Dim storeVal As Double
Dim i As Long, tLng As Long
tst = False
On Error GoTo exitFunc
If Not validArray(Arr) Then GoTo exitFunc
tLng = UBound(Arr) + LBound(Arr)
For i = LBound(Arr) To UBound(Arr) \ 2
storeVal = Arr(i)
Arr(i) = Arr(tLng - i)
Arr(tLng - i) = storeVal
Next
tst = True
exitFunc:
End Sub
'slow uses relative indexing ie 1 will always represent the lower bound of input
'takes only the specified part, so speed is dependent on size
'returns a 0 based array
Function getArrayPartD(testArray() As Double, _
ByVal stIndex As Long, _
ByVal endIndex As Long, _
Optional relativeIndex As Boolean = False, _
Optional tst As Boolean) As Double()
Dim i As Long, tmpArr() As Double, lBnd As Long
tst = False
On Error GoTo exitFunc
If Not validArray(testArray) Then GoTo exitFunc
lBnd = LBound(testArray)
If relativeIndex Then
stIndex = stIndex + (lBnd - 1)
endIndex = endIndex + (lBnd - 1)
End If
If Not isBetweenL(endIndex, lBnd, UBound(testArray)) Then GoTo exitFunc
If Not isBetweenL(stIndex, lBnd, UBound(testArray)) Then GoTo exitFunc
ReDim tmpArr(0 To endIndex - stIndex)
For i = 0 To endIndex - stIndex
tmpArr(i) = testArray(stIndex + i)
Next
getArrayPartD = tmpArr
tst = True
exitFunc:
End Function
Function isBetweenL(test As Long, numLow As Long, numHigh As Long, _
Optional inclusive As Boolean = True) As Boolean
On Error GoTo exitFunc
If inclusive Then
If test >= numLow Then If test <= numHigh Then isBetweenL = True: Exit Function
Else
If test > numLow Then If test < numHigh Then isBetweenL = True: Exit Function
End If
exitFunc:
End Function
'gets the real used range using the first/last col/row functions
Function rUsedrange(withinRange As Range, _
Optional LookIn As XlFindLookIn = xlFormulas, _
Optional showAllData As Boolean = False, _
Optional tst As Boolean) As Range
Dim lr As Long, fr As Long, lc As Long, fc As Long
tst = False
On Error GoTo exitFunc
If withinRange Is Nothing Then GoTo exitFunc
With withinRange.Parent
'will catch values that are in hidden rows/cols eiter way
If showAllData Then If .FilterMode Then .showAllData
lr = LastRow(withinRange, LookIn)
If lr < 1 Then GoTo exitFunc
fr = firstRow(withinRange, LookIn)
lc = LastCol(withinRange, LookIn)
fc = firstCol(withinRange, LookIn)
Set rUsedrange = .Range(.Cells(fr, fc), .Cells(lr, lc))
End With
tst = True
exitFunc:
End Function
'THESE USE THE FIND METHOD FOR LAST/FIRST ROW/COL, use if searching full sheet/large range
'gets last/first row/column (searches within values or formulas)
'the find method seems to have an overhead of about .25 seconds/1000 calls
'the increase in time/range size is then about .7 seconds/2560000 searched cells/1000 calls
Public Function LastRow(withinRange As Range, _
Optional LookIn As XlFindLookIn = xlFormulas, _
Optional tst As Boolean) As Long
Dim Ar As Range, tmp As Long, t As Long
tst = False
On Error GoTo exitFunc
If withinRange Is Nothing Then GoTo exitFunc
With withinRange
If .Areas.Count < 2 Then
LastRow = .Find("*", getCornerRange(withinRange, leftTop), LookIn, xlPart, xlByRows, xlPrevious).Row
Else
On Error Resume Next
For Each Ar In .Areas
tmp = Ar.Find("*", getCornerRange(Ar, leftTop), LookIn, xlPart, xlByRows, xlPrevious).Row
If tmp > LastRow Then LastRow = tmp
Next
End If
End With
tst = True
exitFunc:
If LastRow < 1 Then LastRow = -1
End Function
Public Function LastCol(withinRange As Range, _
Optional LookIn As XlFindLookIn = xlFormulas, _
Optional tst As Boolean) As Long
Dim Ar As Range, tmp As Long, t As Long
tst = False
On Error GoTo exitFunc
With withinRange
If .Areas.Count < 2 Then
LastCol = .Find("*", getCornerRange(withinRange, leftTop), LookIn, xlPart, xlByColumns, xlPrevious).Column
Else
On Error Resume Next
For Each Ar In .Areas
tmp = Ar.Find("*", getCornerRange(Ar, leftTop), LookIn, xlPart, xlByColumns, xlPrevious).Column
If tmp > LastCol Then LastCol = tmp
Next
End If
End With
tst = True
exitFunc:
If LastCol < 1 Then LastCol = -1
End Function
Public Function firstRow(withinRange As Range, _
Optional LookIn As XlFindLookIn = xlFormulas, _
Optional tst As Boolean) As Long
Dim Ar As Range, tmp As Long, notFirst As Boolean, t As Long
tst = False
On Error GoTo exitFunc
If withinRange Is Nothing Then GoTo exitFunc
With withinRange
If .Areas.Count < 2 Then
firstRow = .Find("*", getCornerRange(withinRange, rightBottom), LookIn, xlPart, xlByRows, xlNext).Row
Else
t = rRow(withinRange)
On Error Resume Next
For Each Ar In .Areas
tmp = Ar.Find("*", getCornerRange(Ar, rightBottom), LookIn, xlPart, xlByRows, xlNext).Row
If tmp <> 0 Then
If notFirst Then
If tmp < firstRow Then firstRow = tmp: If firstRow = t Then Exit For
Else
notFirst = True
firstRow = tmp
If firstRow = t Then Exit For
End If
End If
Next
End If
End With
tst = True
exitFunc:
If firstRow < 1 Then firstRow = -1
End Function
Public Function firstCol(withinRange As Range, _
Optional LookIn As XlFindLookIn = xlFormulas, _
Optional tst As Boolean) As Long
Dim Ar As Range, tmp As Long, notFirst As Boolean, t As Long
tst = False
On Error GoTo exitFunc
If withinRange Is Nothing Then GoTo exitFunc
With withinRange
If .Areas.Count < 2 Then
firstCol = .Find("*", getCornerRange(withinRange, rightBottom), LookIn, xlPart, xlByColumns, xlNext).Column
Else
t = rColumn(withinRange)
On Error Resume Next
For Each Ar In .Areas
tmp = Ar.Find("*", getCornerRange(Ar, rightBottom), LookIn, xlPart, xlByColumns, xlNext).Column
If tmp <> 0 Then
If notFirst Then
If tmp < firstCol Then: firstCol = tmp: If firstCol = t Then Exit For
Else
notFirst = True
firstCol = tmp
If firstCol = t Then Exit For
End If
End If
Next
End If
End With
tst = True
exitFunc:
If firstCol < 1 Then firstCol = -1
End Function
'gets the specified corner of a range
'left top fastest, left bottom slowest
Function getCornerRange(rng As Range, _
Optional whichCorner As cornerCell = rightBottom, _
Optional tst As Boolean) As Range
Dim boundsArr() As Long
Dim funcTest As Boolean
Dim lBnd As Long
tst = False
On Error GoTo exitFunc
With rng
If .Areas.Count = 1 Then
Select Case whichCorner
Case 0 'lefttop
Set getCornerRange = .Cells(1)
Case 1 'right top
Set getCornerRange = .Cells(.Columns.Count)
Case 2 'left bottom
Set getCornerRange = .Cells(.Rows.Count, 1)
Case 3 'right bottom
Set getCornerRange = .Cells(.Rows.Count, .Columns.Count)
End Select
Else
Set getCornerRange = getCornerRange(getBoundRange(rng), whichCorner)
End If
End With
tst = True
exitFunc:
End Function
Function getBoundRange(r As Range, _
Optional tst As Boolean) As Range
' Returns a single-area range bounding the areas in r
' pgc01 http://www.mrexcel.com/forum/showpos...64&postcount=3
Dim i As Long
tst = False
On Error GoTo exitFunc
If r Is Nothing Then Exit Function
Set getBoundRange = r.Areas(1)
For i = 2 To r.Areas.Count
Set getBoundRange = Range(getBoundRange, r.Areas(i))
Next i
tst = True
exitFunc:
End Function
Function rRow(inputRange As Range, _
Optional tst As Boolean) As Long
Dim Ar As Range, t As Long
tst = False
On Error GoTo exitFunc
If inputRange Is Nothing Then GoTo exitFunc
If inputRange.Areas.Count = 1 Then rRow = inputRange.Row: tst = True: GoTo exitFunc
rRow = Application.Rows.Count + 1
For Each Ar In inputRange.Areas
t = Ar.Row
If t < rRow Then rRow = t
Next
tst = True
exitFunc:
End Function
Function rColumn(inputRange As Range, _
Optional tst As Boolean) As Long
Dim Ar As Range, t As Long
tst = False
On Error GoTo exitFunc
If inputRange Is Nothing Then GoTo exitFunc
If inputRange.Areas.Count = 1 Then rColumn = inputRange.Column: tst = True: GoTo exitFunc
rColumn = Application.Columns.Count + 1
For Each Ar In inputRange.Areas
t = Ar.Column
If t < rColumn Then rColumn = t
Next
tst = True
exitFunc:
End Function
