Note: Yes. It's big. I'm not expecting commensurately long/detailed answers (though if anyone wants to write one, you'll definitely be receiving a substantial bounty). This class is going to be used a lot in my VBA development so any reviews at all would be immensely helpful. Even if it's just a typo somewhere or an edge case that's not being checked or functionality you think should be added to it or even just a Gut-Check on coding smells, readability and the like.
If you want a paste-able version of this code, please see this github repo
I do a lot of data analysis with spreadsheets. VBA has no in-built array functions (sorting, filtering etc.). This is a problem.
So, I took my accumulated collection of Array-manipulation methods, cleaned them up and turned them into a Class: CLS_2D_VarArray.
It is also supposed to be paired with my collection of Standard Methods, in a Base_Standard_Methods Module, and with CLS_Comparison_Predicate which is used to pass logical expressions to functions.
I would love to get peoples' thoughts on it.
Class-Level stuff:
Type of Array:
I only use 2-D Variant Arrays, declared thus:
Dim arr As Variant
Redim arr(1 to 5, 1 to 5)
Only declared that way for various reasons which I won't go into here.
Only 2-Dimensional because that covers 95% of my use-cases, and supporting multi-dimensional operations would cause a lot of additional complexity.
Properties:
Private Type TVarArray
varArray As Variant
ColumnHeaderIndexes As Dictionary '/ Set when SetArray is called with hasHeaders = True
PrintRange As Range '/ Set whenever Me.PrintToSheet is called
End Type
Private This As TVarArray
Behaviour:
All the functions are designed to be chain-able. So, with the exception of CopyArray(), which returns a copy of VarArray, or GetArray(), which returns VarArray itself, all functions return a new Class object.
E.G. I can do the following:
Set filteredArray = baseClass.RemoveIndexes().KeepHeaders().RemoveByPredicate()
This allows me to
- Never have to worry about over-writing the original Array/Data
- Perform operations in sequence without having to keep re-inserting array outputs into new class objects.
All inputs are checked/validated immediately upon calling a public method, before any business logic, and even if they will be checked again later on.
For now, failed validations just Debug.Print, MsgBox and then Stop because this is strictly for internal use, I'm the only developer and it's a lot more useful to me to just Stop where the error is.
Most of the public methods validate inputs and then call Internal... methods for the actual operations.
Method List
SetArray,GetArray
CopyArray,CopyClass
CheckTargets
IsAllocated,GetBounds,IsListArray,SetColumnHeaderIndexes
InternalCopyArray
InternalCopyClass
InternalRemoveIndexes
InvertTargetIndexes
RemoveIndexes,KeepIndexes
RemoveByPredicate,KeepByPredicate
RemoveHeaders,KeepHeaders
ColumnIndexOfHeader
ArrayListFromIndex
AddData
MapHeadersToIndexes
InsertIndex,FillIndex
ReplaceValues
SortRows
PrintTosheetExternal Methods/Classes included for context:
CLS_Comparison_Predicate
External Methods
Methods:
SetArray, GetArray
Not properties because SetArray needs to know if the array has headers or not, and property Get/Set/Lets can't have multiple arguments.
I had 2 options for headers. I could either assume that every array has headers, and ignore duplicate headers, or require a boolean declaration. I decided a declaration would be more annoying, but was preferable to ignoring duplicate-header collisions.
Public Sub SetArray(ByRef inputArray As Variant, Optional ByVal hasHeaders As Boolean = False)
If Not IsArray(inputArray) Then
PrintErrorMessage "Input is not an array"
Stop
Else
If Not DimensionCountOfArray(inputArray) = 2 Then
PrintErrorMessage "Input Array must be 2-dimensional"
Stop
Else
With This
.varArray = inputArray
If hasHeaders Then SetColumnHeaderIndexes Else Set .ColumnHeaderIndexes = Nothing
End With
End If
End If
End Sub
Public Function GetArray() As Variant
GetArray = This.varArray
End Function
CopyArray, CopyClass
CopyArray also contains an argument for transposing the array.
Public Function CopyClass(Optional ByVal copyTransposed As Boolean = False) As CLS_2D_VarArray
Dim newClass As CLS_2D_VarArray
Set newClass = InternalCopyClass()
With newClass
If copyTransposed Then .ArrayObject = Transpose2dArray(.ArrayObject)
End With
Set CopyClass = newClass
End Function
Public Function CopyArray(Optional ByVal copyTransposed As Boolean) As Variant
'/ Returns a new array object with identical contents to VarArray.
CopyArray = InternalCopyArray
If copyTransposed Then CopyArray = Transpose2dArray(CopyArray)
End Function
CheckTargets
Which is a catch-all function for checking all possible inputs and should be called, in some form, from every public method (apart from the simple Get/Copy methods).
Private Function CheckTargets(Optional ByVal checkDimension As Variant, Optional ByVal checkIndex As Variant, Optional ByRef checkIndexList As Variant)
'/ Checks that VarArray is allocated
'/ If supplied, checks that target Dimension/Indexes exist
If Not IsAllocated Then
PrintErrorMessage "Array has not been allocated"
Stop
End If
Dim LB1 As Long, UB1 As Long
Dim LB2 As Long, UB2 As Long
GetBounds LB1, UB1, LB2, UB2
If Not IsMissing(checkDimension) Then
If Not (checkDimension = 1 Or checkDimension = 2) Then
PrintErrorMessage "Target Dimension does not exist"
Stop
End If
End If
If Not IsMissing(checkIndex) Then
If Not ((checkDimension = 1 And checkIndex >= LB1 And checkIndex <= UB1) Or (checkDimension = 2 And checkIndex >= LB2 And checkIndex <= UB2)) Then
PrintErrorMessage "Target Index does not exist"
Stop
End If
End If
If Not IsMissing(checkIndexList) Then
If Not IsListArray(checkIndexList) <> 1 Then '/ Check that indexesToRemove is an arrayList
PrintErrorMessage "checkIndexList must be an arrayList"
Stop
End If
Dim listLB1 As Long, listUB1 As Long
listLB1 = LBound(checkIndexList)
listUB1 = UBound(checkIndexList)
Dim ix As Long
Dim testIndex As Long
For ix = listLB1 To listUB1
testIndex = checkIndexList(ix)
If Not ((checkDimension = 1 And testIndex >= LB1 And testIndex <= UB1) Or (checkDimension = 2 And testIndex >= LB2 And testIndex <= UB2)) Then
PrintErrorMessage "Target Index does not exist"
Stop
End If
Next ix
End If
End Function
IsAllocated, GetBounds, IsListArray, SetColumnHeaderIndexes
Simple utility functions.
Private Function IsAllocated() As Boolean
On Error GoTo CleanFail:
IsAllocated = IsArray(This.varArray) And Not IsError(LBound(This.varArray, 1)) And LBound(This.varArray, 1) <= UBound(This.varArray, 1)
On Error GoTo 0
CleanExit:
Exit Function
CleanFail:
On Error GoTo 0
IsAllocated = False
Resume CleanExit
End Function
Private Function IsListArray(ByRef checkVar As Variant) As Boolean
Dim passedChecks As Boolean
passedChecks = True
If Not IsArray(checkVar) Then
passedChecks = False
PrintErrorMessage "Input is not an array"
Stop
End If
If Not DimensionCountOfArray(checkVar) = 1 Then
passedChecks = False
PrintErrorMessage "Input Array must be 1-dimensional"
Stop
End If
IsListArray = passedChecks
End Function
Private Sub SetColumnHeaderIndexes()
Set This.ColumnHeaderIndexes = New Dictionary
Dim LB1 As Long, LB2 As Long, UB2 As Long
GetBounds LB1:=LB1, LB2:=LB2, UB2:=UB2
Dim header As Variant
Dim columnIndex As Long
Dim iy As Long
For iy = LB2 To UB2
columnIndex = iy
header = This.varArray(LB1, iy)
This.ColumnHeaderIndexes.item(header) = columnIndex
Next iy
End Sub
Private Sub GetBounds( _
Optional ByRef LB1 As Variant, Optional ByRef UB1 As Variant, _
Optional ByRef LB2 As Variant, Optional ByRef UB2 As Variant)
'/ Assigns the L/U Bounds of the array for the specified dimension arguments
If Not IsMissing(LB1) Then LB1 = LBound(This.varArray, 1)
If Not IsMissing(UB1) Then UB1 = UBound(This.varArray, 1)
If Not IsMissing(LB2) Then LB2 = LBound(This.varArray, 2)
If Not IsMissing(UB2) Then UB2 = UBound(This.varArray, 2)
End Sub
InternalCopyArray
This is the core internal function. Used for copying the array and removing indexes.
Private Function InternalCopyArray(Optional ByRef targetDimension As Variant, Optional ByRef indexesToIgnore As Variant) As Variant
'/ Returns a new array object with identical contents to This.VarArray.
'/ If target dimension & indexes are specified, will skip over them rather than copying, effectively removing them from the result.
CheckTargets targetDimension, checkIndexList:=indexesToIgnore
Dim targetsArePresent As Boolean
targetsArePresent = (Not IsMissing(targetDimension)) And (Not IsMissing(indexesToIgnore))
Dim LB1 As Long, UB1 As Long
Dim LB2 As Long, UB2 As Long
GetBounds LB1, UB1, LB2, UB2
Dim newArray As Variant
If targetsArePresent Then
Select Case targetDimension
Case 1
ReDim newArray(LB1 To UB1 - DimLength(indexesToIgnore, 1), LB2 To UB2)
Case 2
ReDim newArray(LB1 To UB1, LB2 To UB2 - DimLength(indexesToIgnore, 1))
End Select
Else
ReDim newArray(LB1 To UB1, LB2 To UB2)
End If
Dim i As Long, j As Long
Dim ignoreCounter As Long
Dim ignoreIndex As Boolean
Dim copyElement As Variant
For i = LB1 To UB1
If targetsArePresent Then If targetDimension = 2 Then ignoreCounter = 0 '/ reset each row if targeting columns
For j = LB2 To UB2
If IsObject(This.varArray(i, j)) Then Set copyElement = This.varArray(i, j) Else copyElement = This.varArray(i, j)
If targetsArePresent Then
ignoreIndex = False
Select Case targetDimension
Case 1
ignoreIndex = Not IsNull(IndexIn1DArray(indexesToIgnore, i))
Case 2
ignoreIndex = Not IsNull(IndexIn1DArray(indexesToIgnore, j))
End Select
If ignoreIndex Then
If targetDimension = 1 Then
If j = LB2 Then ignoreCounter = ignoreCounter + 1 '/ only increment once per row if rows targeted
Else
ignoreCounter = ignoreCounter + 1
End If
Else
Select Case targetDimension
Case 1
If IsObject(copyElement) Then Set newArray(i - ignoreCounter, j) = copyElement Else newArray(i - ignoreCounter, j) = copyElement
Case 2
If IsObject(copyElement) Then Set newArray(i, j - ignoreCounter) = copyElement Else newArray(i, j - ignoreCounter) = copyElement
End Select
End If
Else
If IsObject(copyElement) Then Set newArray(i, j) = copyElement Else newArray(i, j) = copyElement
End If
Next j
Next i
InternalCopyArray = newArray
End Function
InternalCopyClass
Used to produce the new Class Object outputs for each function.
Private Function InternalCopyClass(Optional ByRef inputArray As Variant) As CLS_2D_VarArray
CheckTargets
Dim newCopy As CLS_2D_VarArray
Set newCopy = New CLS_2D_VarArray
Dim withHeaders As Boolean
withHeaders = Not (This.ColumnHeaderIndexes Is Nothing)
If IsMissing(inputArray) Then
newCopy.SetArray Me.CopyArray(), withHeaders
Else
newCopy.SetArray inputArray, withHeaders
End If
Set newCopy.PrintRange = This.PrintRange
Set InternalCopyClass = newCopy
End Function
InternalRemoveIndexes
Effectively an abstraction layer between input methods and the core CopyArray function.
Private Function InternalRemoveIndexes(ByVal targetDimension As Long, ByRef indexesToRemove As Variant) As CLS_2D_VarArray
'/ Returns a new class object with identical array contents to This.VarArray.
'/ Will skip over target Indexes rather than copying, effectively removing them from the result.
Set InternalRemoveIndexes = InternalCopyClass(InternalCopyArray(targetDimension, indexesToRemove))
End Function
InvertTargetIndexes
Given a list of indexes in a target dimension, returns a list of all the other indexes in that dimension. E.G. given a list of indexes to keep, invert the list and suddenly it's a list of indexes *not* to keep.
Whenever there is a Keep/Remove function, one will simply invert the target list and pass to the other.
Private Function InvertTargetIndexes(ByVal targetDimension As Long, ByRef targetIndexes As Variant) As Variant
'/ returns a listArray containing all the indexes NOT in targetIndexes.
Dim LB1 As Long, UB1 As Long
Dim LB2 As Long, UB2 As Long
GetBounds LB1, UB1, LB2, UB2
Dim invertedIndexes As Variant
ReDim invertedIndexes(1 To DimLength(This.varArray, targetDimension) - DimLength(targetIndexes, 1))
Dim startIndex As Long, endIndex As Long
Select Case targetDimension
Case 1
startIndex = LB1
endIndex = UB1
Case 2
startIndex = LB2
endIndex = UB2
End Select
Dim matchCounter As Long
Dim ix As Long
For ix = startIndex To endIndex
If IsNull(IndexIn1DArray(targetIndexes, ix)) Then '/ is not in indexes to keep
matchCounter = matchCounter + 1
invertedIndexes(matchCounter) = ix
End If
Next ix
InvertTargetIndexes = invertedIndexes
End Function
RemoveIndexes, KeepIndexes
Public Function RemoveIndexes(ByVal targetDimension As Long, ByRef indexesToRemove As Variant) As CLS_2D_VarArray
'/ Returns a new class object with identical array contents to VarArray.
'/ Will skip over target Indexes rather than copying, effectively removing them from the result.
If (Not IsMissing(targetDimension)) And (Not IsMissing(indexesToRemove)) Then
CheckTargets targetDimension, checkIndexList:=indexesToRemove
Set KeepIndexes = InternalRemoveIndexes(targetDimension, indexesToRemove)
Else
PrintErrorMessage "Both target Dimension and target Indexes must be supplied"
Stop
End If
End Function
Public Function KeepIndexes(ByVal targetDimension As Long, ByRef indexesToKeep As Variant) As CLS_2D_VarArray
'/ Returns a new class object with identical array contents to VarArray.
'/ Will skip over non-target Indexes rather than copying, effectively removing them from the result.
If (Not IsMissing(targetDimension)) And (Not IsMissing(indexesToKeep)) Then
CheckTargets targetDimension, checkIndexList:=indexesToKeep
Set KeepIndexes = InternalRemoveIndexes(targetDimension, InvertTargetIndexes(indexesToKeep))
Else
PrintErrorMessage "Both target Dimension and target Indexes must be supplied"
Stop
End If
End Function
RemoveByPredicate,KeepByPredicate
Filter the array, based on values in a target index, using a logical predicate.
Public Function RemoveByPredicate(ByVal targetDimension As Long, ByVal targetIndex As Long, ByRef predicate As CLS_Comparison_Predicate) As CLS_2D_VarArray
'/ Use the predicate to build a list of indexes to remove, then pass to InternalRemoveIndexes
'/ E.G. dimension 2, index 1, predicate(GreaterThan, 9000) will remove all rows where the value in column 1 is Greater Than 9,000
If predicate Is Nothing Then
PrintErrorMessage "Predicate must be set"
Stop
End If
CheckTargets targetDimension, targetIndex
Dim arrayListAtIndex As Variant
arrayListAtIndex = ArrayListFromIndex(targetDimension, targetIndex)
Dim LB1 As Long, UB1 As Long
AssignArrayBounds arrayListAtIndex, LB1, UB1
Dim removeCounter As Long
Dim indexesToRemove As Variant
ReDim indexesToRemove(1 To 1)
Dim ix As Long
For ix = LB1 To UB1
If predicate.Compare(arrayListAtIndex(ix)) Then
removeCounter = removeCounter + 1
ReDim Preserve indexesToRemove(1 To removeCounter)
indexesToRemove(removeCounter) = ix
End If
Next ix
If removeCounter > 0 Then
'/ Target Dimension for removal will be the opposite to the one we were comparing
Select Case targetDimension
Case 1
targetDimension = 2
Case 2
targetDimension = 1
End Select
Set RemoveByPredicate = InternalRemoveIndexes(targetDimension, indexesToRemove)
Else
Set RemoveByPredicate = InternalCopyClass
End If
End Function
Public Function KeepByPredicate(ByVal targetDimension As Long, ByVal targetIndex As Long, ByRef predicate As CLS_Comparison_Predicate) As CLS_2D_VarArray
'/ Inverts the predicate, then passes to RemoveByPredicate
If predicate Is Nothing Then
PrintErrorMessage "Predicate must be set"
Stop
End If
CheckTargets targetDimension, targetIndex
Dim invertedPredicate As CLS_Comparison_Predicate
Set invertedPredicate = predicate.Copy(copyInverted:=True)
Set KeepByPredicate = Me.RemoveByPredicate(targetDimension, targetIndex, invertedPredicate)
End Function
RemoveHeaders, KeepHeaders
Public Function RemoveHeaders(ByVal headerList As Variant) As CLS_2D_VarArray
'/ Use the headers to build a list of indexes to remove, then pass to InternalRemoveIndexes
If Not IsListArray(headerList) Then
PrintErrorMessage "headerList must be a listArray"
Stop
End If
Const TARGET_DIMENSION As Long = 2 '/ Targeting columns
Dim indexesOfHeaders As Variant
indexesOfHeaders = GetIndexesOfHeaders(headerList)
Set KeepHeaders = InternalRemoveIndexes(TARGET_DIMENSION, indexesOfHeaders)
End Function
Public Function KeepHeaders(ByVal headerList As Variant) As CLS_2D_VarArray
'/ Use the headers to build a list of indexes to remove, then pass to InternalRemoveIndexes
If Not IsListArray(headerList) Then
PrintErrorMessage "headerList must be a listArray"
Stop
End If
Const TARGET_DIMENSION As Long = 2 '/ Targeting columns
Dim indexesOfHeaders As Variant
indexesOfHeaders = GetIndexesOfHeaders(headerList)
Set KeepHeaders = InternalRemoveIndexes(TARGET_DIMENSION, InvertTargetIndexes(2, indexesOfHeaders))
End Function
ColumnIndexOfHeader
Public Function ColumnIndexOfHeader(ByVal header As Variant) As Variant
'/ Returns NULL if header cannot be found in ColumnHeaderIndexes
With This
If .ColumnHeaderIndexes.Exists(header) Then ColumnIndexOfHeader = .ColumnHeaderIndexes.item(header) Else ColumnIndexOfHeader = Null
End With
End Function
ArrayListFromIndex
Public Function ArrayListFromIndex(ByVal targetDimension As Long, ByVal targetIndex As Long) As Variant
'/ Given a target index in VarArray, return a 1-D array of all the items in that index.
'/ The returned array will still retain the same indexes as the original
CheckTargets targetDimension, targetIndex
Dim LB1 As Long, UB1 As Long
Dim LB2 As Long, UB2 As Long
GetBounds LB1, UB1, LB2, UB2
Dim arrayList As Variant
Dim i As Long
Select Case targetDimension
Case 1
ReDim arrayList(LB2 To UB2)
For i = LB2 To UB2
If IsObject(This.varArray(targetIndex, i)) Then Set arrayList(i) = This.varArray(targetIndex, i) Else arrayList(i) = This.varArray(targetIndex, i)
Next i
Case 2
ReDim arrayList(LB1 To UB1)
For i = LB1 To UB1
If IsObject(This.varArray(i, targetIndex)) Then Set arrayList(i) = This.varArray(i, targetIndex) Else arrayList(i) = This.varArray(i, targetIndex)
Next i
End Select
ArrayListFromIndex = arrayList
End Function
AddData
Given some input array, find the corresponding headers in VarArray and copy the contents to new rows.
Public Sub AddData(ByRef inputArray As CLS_2D_VarArray)
'/ Takes the input array, determines that all headers exist in this array then writes all data to newlines
CheckTargets
If This.ColumnHeaderIndexes Is Nothing Then
PrintErrorMessage "Cannot match data as VarArray has no headers"
Stop
End If
Dim inputData As Variant
inputData = inputArray.GetArray
If IsEmpty(inputData) Then
PrintErrorMessage "Input array has no data"
Stop
End If
Dim mapHeaders As Dictionary
Set mapHeaders = MapHeadersToIndexes(inputData)
Dim inputLB1 As Long, inputUB1 As Long
Dim inputLB2 As Long, inputUB2 As Long
AssignArrayBounds inputData, inputLB1, inputUB1, inputLB2, inputUB2
Dim thisLB1 As Long, thisUB1 As Long
Dim thisLB2 As Long, thisUB2 As Long
GetBounds thisLB1, thisUB1, thisLB2, thisUB2
Dim thisArray As Variant
thisArray = This.varArray
thisArray = Transpose2dArray(thisArray)
ReDim Preserve thisArray(thisLB2 To thisUB2, thisLB1 To thisUB1 + (DimLength(inputData, 1) - 1)) '/ -1 because not copying header row
thisArray = Transpose2dArray(thisArray)
Dim header As Variant
Dim columnIndex As Long
Dim copyElement As Variant
Dim ix As Long, iy As Long '/ inputData indexes
Dim thisRow As Long, thisCol As Long '/ thisArray indexes
For iy = inputLB2 To inputUB2
header = inputData(inputLB1, iy)
columnIndex = mapHeaders(header)
thisCol = columnIndex
For ix = inputLB1 + 1 To inputUB1 '/ +1 for ignoring headers
thisRow = thisUB1 + (ix - (inputLB1 + 1) + 1)
If IsObject(inputData(ix, iy)) Then Set thisArray(thisRow, thisCol) = inputData(ix, iy) Else thisArray(thisRow, thisCol) = inputData(ix, iy)
Next ix
Next iy
Me.SetArray (thisArray)
End Sub
MapHeadersToIndexes
Used to map headers for AddData
Private Function MapHeadersToIndexes(ByRef inputData As Variant) As Dictionary
'/ For each header in inputData, finds the matching header in VarArray, adds the header/index to a dictionary
'/ Throws an error if a header cannot be matched to VarArray
Dim LB1 As Long
Dim LB2 As Long, UB2 As Long
AssignArrayBounds inputData, LB1, LB2:=LB2, UB2:=UB2
Dim mapHeaders As Dictionary
Set mapHeaders = New Dictionary
Dim header As Variant
Dim columnIndex As Long
Dim iy As Long
For iy = LB2 To UB2
header = inputData(LB1, iy)
If This.ColumnHeaderIndexes.Exists(header) Then
columnIndex = This.ColumnHeaderIndexes.item(header)
mapHeaders.Add header, columnIndex
Else
PrintErrorMessage "Header "" & cstr(header) & "" does not exist in this array"
Stop
End If
Next iy
Set MapHeadersToIndexes = mapHeaders
End Function
InsertIndex,FillIndex
Public Function InsertIndex(ByVal targetDimension As Long, ByVal targetIndex As Long, Optional ByVal header As Variant, Optional ByVal fillValue As Variant) As CLS_2D_VarArray
'/ Returns a copy of VarArray with a new Row/Column by copying VarArray and leaving an extra gap at the specified index.
CheckTargets targetDimension, targetIndex
Dim LB1 As Long, UB1 As Long
Dim LB2 As Long, UB2 As Long
GetBounds LB1, UB1, LB2, UB2
Dim newArr As Variant
If targetDimension = 1 Then ReDim newArr(LB1 To UB1 + 1, LB2 To UB2)
If targetDimension = 2 Then ReDim newArr(LB1 To UB1, LB2 To UB2 + 1)
Dim isAfterTarget As Boolean
Dim sourceValue As Variant
Dim ix As Long, iy As Long
For ix = LB1 To UB1
For iy = LB2 To UB2
sourceValue = This.varArray(ix, iy)
isAfterTarget = targetDimension = 1 And ix >= targetIndex Or targetDimension = 2 And iy >= targetIndex
If isAfterTarget Then
If targetDimension = 1 Then If IsObject(sourceValue) Then Set newArr(ix + 1, iy) = sourceValue Else newArr(ix + 1, iy) = sourceValue
If targetDimension = 2 Then If IsObject(sourceValue) Then Set newArr(ix, iy + 1) = sourceValue Else newArr(ix, iy + 1) = sourceValue
Else
If IsObject(sourceValue) Then Set newArr(ix, iy) = sourceValue Else newArr(ix, iy) = sourceValue
End If
Next iy
Next ix
If Not (IsMissing(fillValue) And IsMissing(header)) Then FillIndex2D newArr, targetDimension, targetIndex, fillValue, header
Set InsertIndex = InternalCopyClass(newArr)
End Function
Public Function FillIndex(ByVal targetDimension As Long, ByVal targetIndex As Long, Optional ByVal fillValue As Variant, Optional ByVal header As Variant) As CLS_2D_VarArray
'/ Fills every element of the index with fill value. If header is provided then the lower-bound of the index will contain the header value.
CheckTargets targetDimension, targetIndex
Dim LB1 As Long, UB1 As Long
Dim LB2 As Long, UB2 As Long
GetBounds LB1, UB1, LB2, UB2
Dim newArray As Variant
newArray = InternalCopyArray
Dim ix As Long, iy As Long
Select Case targetDimension
Case 1
If Not IsMissing(fillValue) Then
For iy = LB2 To UB2
newArray(targetIndex, iy) = fillValue
Next iy
End If
If Not IsMissing(header) Then This.varArray(targetIndex, LB2) = header
Case 2
If Not IsMissing(fillValue) Then
For ix = LB1 To UB1
newArray(ix, targetIndex) = fillValue
Next ix
End If
If Not IsMissing(header) Then This.varArray(LB1, targetIndex) = header
End Select
Set FillIndex = InternalCopyClass(newArray)
End Function
ReplaceValues
Public Function ReplaceValues(ByVal findValue As Variant, ByVal replaceValue As Variant) As CLS_2D_VarArray
'/ Replaces all *exact* occurences of the find value with the replace value. *exact* means the entirety of the array element must match.
'/ Ignores objects.
CheckTargets
Dim newArray As Variant
newArray = InternalCopyArray
Dim LB1 As Long, UB1 As Long
Dim LB2 As Long, UB2 As Long
GetBounds LB1, UB1, LB2, UB2
Dim i As Long, j As Long
For i = LB1 To UB1
For j = LB2 To UB2
If Not IsObject(newArray(i, j)) Then If newArray(i, j) = findValue Then newArray(i, j) = replaceValue
Next j
Next i
Set ReplaceValues = InternalCopyClass(newArray)
End Function
SortRows
Public Function SortRows(ByVal sortIndex As Long, Optional ByVal ignoreHeaders As Boolean = True, Optional ByVal sortOrder As XlSortOrder = xlAscending) As CLS_2D_VarArray
'/ Simple Bubble sort - *Towards* the upper bound of the index - so xlAscending will result in the largest value being at the upper-bound of the index
'/ Will fail if the index contains objects
Const TARGET_DIMENSION As Long = 2 '/ sorting rows IN a column
CheckTargets checkIndex:=sortIndex
Dim LB1 As Long, UB1 As Long
Dim LB2 As Long, UB2 As Long
GetBounds LB1, UB1, LB2, UB2
If ignoreHeaders Then LB1 = LB1 + 1
Dim newArray As Variant
newArray = InternalCopyArray
Dim numIterations As Long
numIterations = DimLength(newArray, 1) - 1
If ignoreHeaders Then numIterations = numIterations - 1
Dim swapValues As Boolean
Dim currentItem As Variant, nextItem As Variant
Dim currentIndex As Long, nextIndex As Long
Dim ix As Long, iy As Long
For ix = 1 To numIterations
For currentIndex = LB1 To UB1 - 1
nextIndex = currentIndex + 1
currentItem = newArray(currentIndex, sortIndex)
nextItem = newArray(nextIndex, sortIndex)
swapValues = False
If sortOrder = xlAscending Then
swapValues = currentItem > nextItem
Else
swapValues = currentItem < nextItem
End If
If swapValues Then
For iy = LB2 To UB2
'/ Sort column must have values, but the rest of the array could easily contain objects as well
If IsObject(newArray(currentIndex, iy)) Then Set currentItem = newArray(currentIndex, iy) Else currentItem = newArray(currentIndex, iy)
If IsObject(newArray(nextIndex, iy)) Then Set nextItem = newArray(nextIndex, iy) Else nextItem = newArray(nextIndex, iy)
If IsObject(currentItem) Then Set newArray(nextIndex, iy) = currentItem Else newArray(nextIndex, iy) = currentItem
If IsObject(nextItem) Then Set newArray(currentIndex, iy) = nextItem Else newArray(currentIndex, iy) = nextItem
Next iy
End If
Next currentIndex
Next ix
Set SortRows = InternalCopyClass(newArray)
End Function
PrintToSheet
Public Sub PrintToSheet(ByRef targetSheet As Worksheet, Optional ByRef startCell As Range)
CheckTargets
If startCell Is Nothing Then Set startCell = targetSheet.Cells(1, 1)
Dim rowCount As Long, colCount As Long
rowCount = DimLength(This.varArray, 1)
colCount = DimLength(This.varArray, 2)
Dim PrintRange As Range
With targetSheet
Set PrintRange = .Range(startCell, .Cells(startCell.row + rowCount - 1, startCell.Column + colCount - 1))
End With
PrintRange = This.varArray
Set This.PrintRange = PrintRange
End Sub
External Methods/Classes included for context:
CLS_Comparison_Predicate
Option Explicit
Private Type TComparer
Operator As ComparisonOperator
RightValue As Variant
End Type
Private This As TComparer
Private Const NULL_ERROR_TEXT As String = "Invalid Compare input. Cannot compare against Null"
Private Const OBJECT_ERROR_TEXT As String = "Invalid Compare input. Input must be a value, not an object"
Private Const EMPTY_ERROR_TEXT As String = "Invalid Compare Input. Input cannot be empty"
Private Const ZLS_ERROR_TEXT As String = "Invalid Compare Input. Input cannot be a Zero-Length-String"
Public Property Let Operator(ByVal inputOperator As ComparisonOperator)
This.Operator = inputOperator
End Property
Public Property Let RightValue(ByVal inputValue As Variant)
CheckInputValue inputValue
This.RightValue = inputValue
End Property
Public Function Copy(Optional ByVal copyInverted As Boolean = False) As CLS_Comparison_Predicate
Dim newPredicate As CLS_Comparison_Predicate
Set newPredicate = New CLS_Comparison_Predicate
With newPredicate
.RightValue = This.RightValue
If Not copyInverted Then
.Operator = This.Operator
Else
Select Case This.Operator
Case NotEqualTo
.Operator = EqualTo
Case LessThan
.Operator = GreaterThanOrEqualTo
Case LessThanOrEqualTo
.Operator = GreaterThan
Case EqualTo
.Operator = NotEqualTo
Case GreaterThanOrEqualTo
.Operator = LessThan
Case GreaterThan
.Operator = LessThanOrEqualTo
Case Else
'/ Should only happen if operator has not been set
PrintErrorMessage "operator has not been set"
Stop
End Select
End If
End With
Set Copy = newPredicate
End Function
Public Function Compare(ByVal inputValue As Variant) As Boolean
CheckInputValue inputValue
With This
Dim isTrue As Boolean
Select Case .Operator
Case NotEqualTo
isTrue = (inputValue <> .RightValue)
Case LessThan
isTrue = (inputValue < .RightValue)
Case LessThanOrEqualTo
isTrue = (inputValue <= .RightValue)
Case EqualTo
isTrue = (inputValue = .RightValue)
Case GreaterThanOrEqualTo
isTrue = (inputValue >= .RightValue)
Case GreaterThan
isTrue = (inputValue > .RightValue)
Case Else
'/ Should only happen if operator has not been set
PrintErrorMessage "operator has not been set"
Stop
End Select
End With
Compare = isTrue
End Function
Private Sub CheckInputValue(ByVal inputValue As Variant)
'/ Check for NULL, Objects, Empty and ZLS
If IsNull(inputValue) Then
PrintErrorMessage NULL_ERROR_TEXT
Stop
End If
If IsObject(inputValue) Then
PrintErrorMessage OBJECT_ERROR_TEXT
Stop
End If
If IsEmpty(inputValue) Then
PrintErrorMessage EMPTY_ERROR_TEXT
Stop
End If
On Error Resume Next
If Len(inputValue) = 0 Then
PrintErrorMessage ZLS_ERROR_TEXT
Stop
End If
On Error GoTo 0
End Sub
External Methods
Public Sub AssignArrayBounds(ByRef targetArray As Variant, _
Optional ByRef LB1 As Variant, Optional ByRef UB1 As Variant, _
Optional ByRef LB2 As Variant, Optional ByRef UB2 As Variant, _
Optional ByRef LB3 As Variant, Optional ByRef UB3 As Variant, _
Optional ByRef LB4 As Variant, Optional ByRef UB4 As Variant, _
Optional ByRef LB5 As Variant, Optional ByRef UB5 As Variant)
'/ Assigns the L/U Bounds of the array for the specified dimension arguments
If Not IsMissing(LB1) Then LB1 = LBound(targetArray, 1)
If Not IsMissing(UB1) Then UB1 = UBound(targetArray, 1)
If Not IsMissing(LB2) Then LB2 = LBound(targetArray, 2)
If Not IsMissing(UB2) Then UB2 = UBound(targetArray, 2)
If Not IsMissing(LB3) Then LB3 = LBound(targetArray, 3)
If Not IsMissing(UB3) Then UB3 = UBound(targetArray, 3)
If Not IsMissing(LB4) Then LB4 = LBound(targetArray, 4)
If Not IsMissing(UB4) Then UB4 = UBound(targetArray, 4)
If Not IsMissing(LB5) Then LB5 = LBound(targetArray, 5)
If Not IsMissing(UB5) Then UB5 = UBound(targetArray, 5)
End Sub
Public Function DimensionCountOfArray(ByRef targetArray As Variant)
Dim maxDimension As Long
Dim errCheck As Variant
maxDimension = 0
Do While maxDimension <= 60000
On Error GoTo maxFound
errCheck = LBound(targetArray, maxDimension + 1)
On Error GoTo 0
maxDimension = maxDimension + 1
Loop
maxFound:
On Error GoTo 0
DimensionCountOfArray = maxDimension
End Function
Public Function IndexIn1DArray(ByRef targetArray As Variant, ByVal searchItem As Variant, Optional ByVal startAtLowerBound As Boolean = True, Optional ByVal nthMatch As Long = 1, Optional ByRef matchWasFound As Boolean) As Variant
'/ Returns the index of the Nth Match of a value in the target array. Returns Null if match not found.
Dim LB1 As Long, UB1 As Long
AssignArrayBounds targetArray, LB1, UB1
Dim startIndex As Long, endIndex As Long, stepValue As Long
If startAtLowerBound Then
startIndex = LB1
endIndex = UB1
stepValue = 1
Else
startIndex = UB1
endIndex = LB1
stepValue = -1
End If
Dim matchCounter As Long
matchCounter = 0
Dim targetIndex As Variant
targetIndex = Null
Dim i As Long
For i = startIndex To endIndex Step stepValue
If targetArray(i) = searchItem Then matchCounter = matchCounter + 1
If matchCounter = nthMatch Then
targetIndex = i
Exit For
End If
Next i
If Not IsNull(targetIndex) Then targetIndex = CLng(targetIndex)
IndexIn1DArray = targetIndex
End Function
Public Function Transpose2dArray(ByRef sourceArray As Variant) As Variant
Dim LB1 As Long, UB1 As Long
Dim LB2 As Long, UB2 As Long
AssignArrayBounds sourceArray, LB1, UB1, LB2, UB2
Dim transposedArray() As Variant
ReDim transposedArray(LB2 To UB2, LB1 To UB1)
Dim i As Long, j As Long
For i = LB1 To UB1
For j = LB2 To UB2
transposedArray(j, i) = sourceArray(i, j)
Next j
Next i
Transpose2dArray = transposedArray
End Function
if then elseon single lines? \$\endgroup\$