7
\$\begingroup\$

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

PrintTosheet

External 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
\$\endgroup\$
  • 3
    \$\begingroup\$ It is possible to have properties with multiple args, but just because you can, doesn't mean you should. So, I'd say using a method was the right call. \$\endgroup\$ – RubberDuck May 23 '16 at 15:47
  • \$\begingroup\$ Any particular reason you're doing if then else on single lines? \$\endgroup\$ – Raystafarian May 24 '16 at 13:33
  • \$\begingroup\$ In general, because I felt it made the function/code more readable. Especially when it's for things like object-checking. \$\endgroup\$ – Kaz May 24 '16 at 13:50
2
\$\begingroup\$

This if isn't the easiest to understand

 If Not ((checkDimension = 1 And checkIndex >= LB1 And checkIndex <= UB1) Or (checkDimension = 2 And checkIndex >= LB2 And checkIndex <= UB2)) Then

I get that it's if not either of these two sets - like this, right?

If _
(Not checkDimension = 1 And Not checkIndex >= LB1 And Not checkIndex <= UB1) _
Or _
(Not checkDimension = 2 And Not checkIndex >= LB2 And Not checkIndex <= UB2) Then

Honestly this might be a time to use that underscore to break something up that, in reality, doesn't need to be broken up - just so it's more clear what the conditions are. Or maybe doing it weird like

Dim firstCondition As Boolean
Dim secondCondition As Boolean

If Not checkDimension = 1 And Not checkIndex >= LB1 And Not checkIndex <= UB1 Then firstCondition = True
If Not checkDimension = 2 And Not checkIndex >= LB2 And Not checkIndex <= UB2 Then secondCondition = True

If firstCondition Or secondCondition Then

Or at least

If Not (checkDimension = 1 And checkIndex >= LB1 And checkIndex <= UB1) Then firstCondition = True
If Not (checkDimension = 2 And checkIndex >= LB2 And checkIndex <= UB2) Then secondCondition = True

Also, since the answer is already here, you say this twice -

 PrintErrorMessage "Target Index does not exist"

Looks like a constant string could be of use ;)

\$\endgroup\$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.