3
\$\begingroup\$

I'm trying to write a class that simplifies the most common operations with arrays and then I want to distribute... Maybe it can help someone...

But I'm facing some problems in make the object simple to use and intuitive.

Here a summary of the public methods:

  • Array to range
  • Array to string
  • Array to text file
  • Array Filter
  • Merge Arrays
  • Range to array
  • Array Sort
  • String to array
  • Text file to array
  • Transpose

Array Filter: Here I have to allow the user to set the filters he needs and that means allow public methods that mean nothing outside the filter method.

Those are the methods:

  • FilterIncludeEquals
  • FilterExcludeEquals
  • FilterIncludeIfBetween
  • FilterIncludeIfContains

and then:

  • FilterApplyTo

How To use (complete code on class module named ArrayManipulation):

Public Sub Test()

    Dim testObject As ArrayManipulation
    Set testObject = New ArrayManipulation

    Dim arrayOfNumbers As Variant
    ReDim arrayOfNumbers(12)
    Dim numbers As Long
    For numbers = 0 To 11
       arrayOfNumbers(numbers) = numbers
    Next

    With testObject
        ' setup filters
        .FilterExcludeEquals 3, 0 'column is not considered for 1d arrays
        .FilterIncludeIfBetween 1, 4, 0
        ' filter the array
        .FilterApplyTo arrayOfNumbers

        ' this create a txt file storing the array
        .ArrayToTextFile arrayOfNumbers, Environ("USERPROFILE") & "\Desktop\Test.txt"

        ' this read the array from the just created file
        .TextFileToArray Environ("USERPROFILE") & "\Desktop\Test.txt", arrayOfNumbers

        ' this write the array on activesheet of you activeworkbook, starting from D3
        .ArrayToRange arrayOfNumbers, Cells(3, 4)
    End With

End Sub

I think the best solution would be to create a second object and then compose the two class and expose a property that returns the "filter" object. But I'm concerned that two modules are less immediate and maybe a person that is not familiar with the IDE can find it more difficult.. So I've decided to put an "Filter" suffix on all filter-related methods.

Do you have any advice?

Sort: At the moment the sort use merge sort but I want to try to write also insertion sort and introsort (as soon as I'll understand it) but more importantly, how can I understand how to sort by multiple columns? I can't find examples that I can understand... How did you do?

Results: All the methods require byRef arguments and the results of the routine overwrite the arguments. Is this approach acceptable? Or is necessary or good practice to use functions?

I would like to have a feedback on the code and on the idea.. Thank you!

Option Explicit

Private pColumnsToReturn    As Variant
Private pFiltersCollection  As Collection
Private pPartialMatchColl   As Collection

Private Enum filterType
    negativeMatch = -1
    exactMatch = 0
    isBetween = 1
    contains = 2
End Enum

Public Property Let ColumnsToReturn(arr As Variant)
    pColumnsToReturn = arr
End Property

' FILTER METHODS ******************************************************************

Public Sub FilterIncludeEquals(ByRef equalTo As Variant, ByRef inColumn As Long, _
                         Optional ByRef isCaseSensitive As Boolean = False)

    If inColumn > -1 Then

        Dim thisFilter              As Collection
        Dim thisFilterType          As filterType

        Set thisFilter = New Collection
        thisFilterType = exactMatch

        With thisFilter
            .Add thisFilterType
            .Add inColumn
            .Add IIf(isCaseSensitive, equalTo, LCase(equalTo))
            .Add isCaseSensitive
        End With

        If pFiltersCollection Is Nothing Then Set pFiltersCollection = New Collection

        pFiltersCollection.Add thisFilter
        Set thisFilter = Nothing

    End If

End Sub

Public Sub FilterExcludeEquals(ByRef equalTo As Variant, ByRef inColumn As Long, _
                         Optional ByRef isCaseSensitive As Boolean = False)

    If inColumn > -1 Then

        Dim thisFilter              As Collection
        Dim thisFilterType          As filterType

        Set thisFilter = New Collection
        thisFilterType = negativeMatch

        With thisFilter
            .Add thisFilterType
            .Add inColumn
            .Add IIf(isCaseSensitive, equalTo, LCase(equalTo))
            .Add isCaseSensitive
        End With

        If pFiltersCollection Is Nothing Then Set pFiltersCollection = New Collection

        pFiltersCollection.Add thisFilter
        Set thisFilter = Nothing

    End If

End Sub

Public Sub FilterIncludeIfBetween(ByRef lowLimit As Variant, ByRef highLimit As Variant, ByRef inColumn As Long)

    If inColumn > -1 Then

        Dim thisFilter              As Collection
        Dim thisFilterType          As filterType

        Set thisFilter = New Collection
        thisFilterType = isBetween

        With thisFilter
            .Add thisFilterType
            .Add inColumn
            .Add lowLimit
            .Add highLimit
        End With

        If pFiltersCollection Is Nothing Then Set pFiltersCollection = New Collection

        pFiltersCollection.Add thisFilter
        Set thisFilter = Nothing

    End If

End Sub

Public Sub FilterIncludeIfContains(ByRef substring As String, Optional ByRef inColumns As Variant = 1)

    If IsArray(inColumns) Or IsNumeric(inColumns) Then

        Dim thisFilterType          As filterType

        Set pPartialMatchColl = New Collection
        thisFilterType = contains

        With pPartialMatchColl
            .Add thisFilterType
            .Add inColumns
            .Add substring
        End With

    End If

End Sub

Public Sub FilterApplyTo(ByRef originalArray As Variant)

    If Not IsArray(originalArray) Then Exit Sub

    If isSingleDimensionalArray(originalArray) Then
        filterOneDimensionalArray originalArray
    Else
        filterTwoDimensionalArray originalArray
    End If

End Sub

Private Sub filterTwoDimensionalArray(ByRef originalArray As Variant)

    Dim firstRow                    As Long
    Dim lastRow                     As Long
    Dim firstColumn                 As Long
    Dim lastColumn                  As Long
    Dim row                         As Long
    Dim col                         As Long
    Dim arrayOfColumnToReturn       As Variant
    Dim partialMatchColumnsArray    As Variant
    Dim result                      As Variant

    result = -1
    arrayOfColumnToReturn = pColumnsToReturn
    If Not pPartialMatchColl Is Nothing Then partialMatchColumnsArray = pPartialMatchColl(2)

    ' If the caller don't pass the array of column to return
    ' create an array with all the columns and preserve the order
    If Not IsArray(arrayOfColumnToReturn) Then
        ReDim arrayOfColumnToReturn(LBound(originalArray, 2) To UBound(originalArray, 2))
        For col = LBound(originalArray, 2) To UBound(originalArray, 2)
            arrayOfColumnToReturn(col) = col
        Next col
    End If

    ' If the caller don't pass an array for partial match
    ' check if it pass the special value 1, if true the
    ' partial match will be performed on values in columns to return
    If Not IsArray(partialMatchColumnsArray) Then
        If partialMatchColumnsArray = 1 Then partialMatchColumnsArray = arrayOfColumnToReturn
    End If

    firstRow = LBound(originalArray, 1)
    lastRow = UBound(originalArray, 1)

    ' main loop
    Dim keepCount           As Long
    Dim filter              As Variant
    Dim currentFilterType   As filterType

    ReDim arrayOfRowsToKeep(lastRow - firstRow + 1) As Variant
    keepCount = 0

    For row = firstRow To lastRow

        ' exact, excluse and between checks
        If Not pFiltersCollection Is Nothing Then
            For Each filter In pFiltersCollection
                currentFilterType = filter(1)
                Select Case currentFilterType
                    Case negativeMatch
                        If filter(4) Then
                            If originalArray(row, filter(2)) = filter(3) Then GoTo Skip
                        Else
                            If LCase(originalArray(row, filter(2))) = filter(3) Then GoTo Skip
                        End If
                    Case exactMatch
                        If filter(4) Then
                            If originalArray(row, filter(2)) <> filter(3) Then GoTo Skip
                        Else
                            If LCase(originalArray(row, filter(2))) <> filter(3) Then GoTo Skip
                        End If
                    Case isBetween
                        If originalArray(row, filter(2)) < filter(3) _
                        Or originalArray(row, filter(2)) > filter(4) Then GoTo Skip
                End Select
            Next filter
        End If

        ' partial match check
        If Not pPartialMatchColl Is Nothing Then
            If IsArray(partialMatchColumnsArray) Then
                For col = LBound(partialMatchColumnsArray) To UBound(partialMatchColumnsArray)
                    If InStr(1, originalArray(row, partialMatchColumnsArray(col)), pPartialMatchColl(3), vbTextCompare) > 0 Then
                        GoTo Keep
                    End If
                Next
                GoTo Skip
            End If
        End If
Keep:
        arrayOfRowsToKeep(keepCount) = row
        keepCount = keepCount + 1
Skip:
    Next row

    ' create results array
    If keepCount > 0 Then

        firstRow = LBound(originalArray, 1)
        lastRow = LBound(originalArray, 1) + keepCount - 1
        firstColumn = LBound(originalArray, 2)
        lastColumn = LBound(originalArray, 2) + UBound(arrayOfColumnToReturn) - LBound(arrayOfColumnToReturn)

        ReDim result(firstRow To lastRow, firstColumn To lastColumn)

        For row = firstRow To lastRow
            For col = firstColumn To lastColumn
                result(row, col) = originalArray(arrayOfRowsToKeep(row - firstRow), arrayOfColumnToReturn(col - firstColumn + LBound(arrayOfColumnToReturn)))
            Next col
        Next row

    End If

    originalArray = result
    If IsArray(result) Then Erase result

End Sub

Private Sub filterOneDimensionalArray(ByRef originalArray As Variant)

    Dim firstRow                    As Long
    Dim lastRow                     As Long
    Dim firstColumn                 As Long
    Dim lastColumn                  As Long
    Dim row                         As Long
    Dim col                         As Long
    Dim arrayOfColumnToReturn       As Variant
    Dim partialMatchColumnsArray    As Variant
    Dim result                      As Variant

    result = -1

    firstRow = LBound(originalArray)
    lastRow = UBound(originalArray)

    ' main loop
    Dim keepCount           As Long
    Dim filter              As Variant
    Dim currentFilterType   As filterType

    ReDim arrayOfRowsToKeep(lastRow - firstRow + 1) As Variant
    keepCount = 0

    For row = firstRow To lastRow

        ' exact, excluse and between checks
        If Not pFiltersCollection Is Nothing Then
            For Each filter In pFiltersCollection
                currentFilterType = filter(1)
                Select Case currentFilterType
                    Case negativeMatch
                        If filter(4) Then
                            If originalArray(row) = filter(3) Then GoTo Skip
                        Else
                            If LCase(originalArray(row)) = filter(3) Then GoTo Skip
                        End If
                    Case exactMatch
                        If filter(4) Then
                            If originalArray(row) <> filter(3) Then GoTo Skip
                        Else
                            If LCase(originalArray(row)) <> filter(3) Then GoTo Skip
                        End If
                    Case isBetween
                        If originalArray(row) < filter(3) _
                        Or originalArray(row) > filter(4) Then GoTo Skip
                End Select
            Next filter
        End If

        ' partial match check
        If Not pPartialMatchColl Is Nothing Then
            If InStr(1, originalArray(row), pPartialMatchColl(3), vbTextCompare) > 0 Then
                GoTo Keep
            End If
            GoTo Skip
        End If
Keep:
        arrayOfRowsToKeep(keepCount) = row
        keepCount = keepCount + 1
Skip:
    Next row

    ' create results array
    If keepCount > 0 Then

        firstRow = LBound(originalArray, 1)
        lastRow = LBound(originalArray, 1) + keepCount - 1

        ReDim result(firstRow To lastRow)

        For row = firstRow To lastRow
            result(row) = originalArray(arrayOfRowsToKeep(row - firstRow))
        Next row

    End If

    originalArray = result
    If IsArray(result) Then Erase result

End Sub

' TRANSPOSE ARRAY ******************************************************************

Public Sub Transpose(ByRef originalArray As Variant)

    If Not IsArray(originalArray) Then Exit Sub
    If isSingleDimensionalArray(originalArray) Then Exit Sub

    Dim row             As Long
    Dim column          As Long
    Dim firstRow        As Long
    Dim lastRow         As Long
    Dim firstColumn     As Long
    Dim lastColumn      As Long

    firstRow = LBound(originalArray, 1)
    firstColumn = LBound(originalArray, 2)
    lastRow = UBound(originalArray, 1)
    lastColumn = UBound(originalArray, 2)

    ReDim tempArray(firstColumn To lastColumn, firstRow To lastRow) As Variant

    For row = firstColumn To lastColumn
        For column = firstRow To lastRow
            tempArray(row, column) = originalArray(column, row)
        Next column
    Next row

    originalArray = tempArray

    Erase tempArray

End Sub

Private Function isSingleDimensionalArray(myArray As Variant) As Boolean

    Dim testDimension As Long

    testDimension = -1
    On Error Resume Next
    testDimension = UBound(myArray, 2)
    On Error GoTo 0
    isSingleDimensionalArray = (testDimension = -1)

End Function

' ARRAY TO STRING ******************************************************************

Public Sub ArrayToString(ByRef originalArray As Variant, ByRef stringToReturn As String, _
                         Optional colSeparator As String = ",", Optional rowSeparator As String = ";")

    Dim firstRow        As Long
    Dim lastRow         As Long
    Dim firstColumn     As Long
    Dim lastColumn      As Long
    Dim row             As Long
    Dim col             As Long

    If Not IsArray(originalArray) Then Exit Sub

    ' Join single dimension array
    If isSingleDimensionalArray(originalArray) Then
        stringToReturn = Join(originalArray, colSeparator)
        Exit Sub
    End If

    firstRow = LBound(originalArray, 1)
    lastRow = UBound(originalArray, 1)
    firstColumn = LBound(originalArray, 2)
    lastColumn = UBound(originalArray, 2)

    ReDim rowArray(firstRow To lastRow) As Variant
    ReDim tempArray(firstColumn To lastColumn) As Variant

    For row = firstRow To lastRow
        ' fill array with values of the entire row
        For col = firstColumn To lastColumn
            tempArray(col) = originalArray(row, col)
        Next col
        rowArray(row) = Join(tempArray, colSeparator)
    Next row

    ' convert rowArray to string
    stringToReturn = Join(rowArray, rowSeparator)

    Erase rowArray
    Erase tempArray

End Sub

' STRING TO ARRAY ******************************************************************

Public Sub StringToArray(ByRef myString As String, ByRef arrayToReturn As Variant, _
                  Optional colSeparator As String = ",", Optional rowSeparator As String = ";")

    If myString = vbNullString Then Exit Sub

    Dim rowArr          As Variant
    ReDim tempArr(0, 0) As Variant
    Dim colArr          As Variant
    Dim firstRow        As Long
    Dim lastRow         As Long
    Dim firstColumn     As Long
    Dim lastColumn      As Long
    Dim row             As Long
    Dim col             As Long

    ' get the dimensions of the resulting array
    rowArr = Split(myString, rowSeparator)
    firstRow = LBound(rowArr)
    lastRow = UBound(rowArr)

    colArr = Split(rowArr(firstRow), colSeparator)
    firstColumn = LBound(colArr)
    lastColumn = UBound(colArr)

    ' return one dimension array
    If firstColumn = lastColumn Then
        arrayToReturn = rowArr
        Exit Sub
    End If

    ' dim result array
    ReDim tempArr(firstRow To lastRow, firstColumn To lastColumn)

    For row = firstRow To lastRow
        ' split each row
        colArr = Split(rowArr(row), colSeparator)
        For col = firstColumn To lastColumn
            ' fill result array
            If IsDate(colArr(col)) Then
                tempArr(row, col) = CDate(colArr(col))
            Else
                tempArr(row, col) = colArr(col)
            End If
        Next col
    Next row

    arrayToReturn = tempArr

    Erase tempArr
    Erase rowArr
    Erase colArr

End Sub

' ARRAY TO TEXT FILE ******************************************************************

Public Sub ArrayToTextFile(ByRef originalArray As Variant, ByRef fullPath As String, _
                           Optional colSeparator As String = ",", Optional rowSeparator As String = ";")

    Dim fso             As FileSystemObject
    Dim resultingString As String

    Set fso = New FileSystemObject

    Me.ArrayToString originalArray, resultingString, colSeparator, rowSeparator

    With fso.CreateTextFile(fullPath)
        .Write resultingString
    End With

    Set fso = Nothing

End Sub

' TEXT FILE TO ARRAY ******************************************************************

Public Sub TextFileToArray(ByRef fullPath As String, ByRef arrayToReturn As Variant, _
                          Optional colSeparator As String = ",", Optional rowSeparator As String = ";")


    Dim fso             As FileSystemObject
    Dim resultingString As String

    Set fso = New FileSystemObject

    If fso.FileExists(fullPath) Then

        With fso.OpenTextFile(fullPath)
            resultingString = .ReadAll
        End With

        Me.StringToArray resultingString, arrayToReturn, colSeparator, rowSeparator

    End If

    Set fso = Nothing

End Sub

' ARRAY TO RANGE ******************************************************************

Public Sub ArrayToRange(ByRef myArray As Variant, ByRef TopLeftCell As Range)

    Dim totRows         As Long
    Dim totColumns      As Long

    If Not IsArray(myArray) Then Exit Sub

    If isSingleDimensionalArray(myArray) Then
        totRows = 1
        totColumns = UBound(myArray) - LBound(myArray) + 1
    Else
        totRows = UBound(myArray, 1) - LBound(myArray, 1) + 1
        totColumns = UBound(myArray, 2) - LBound(myArray, 2) + 1
    End If

    TopLeftCell.Resize(totRows, totColumns).value = myArray

End Sub

' RANGE TO ARRAY *******************************************************************

Public Sub RangeToArray(ByRef TopLeftCell As Range, ByRef ResultingArray As Variant)

    ResultingArray = TopLeftCell.CurrentRegion.value

End Sub

' MERGE *****************************************************************************

Public Sub MergeArrays(ByRef MainArray As Variant, ByRef ArrayOfArrays As Variant)

    If isSingleDimensionalArray(MainArray) Then
        MergeArrays1D MainArray, ArrayOfArrays
    Else
        MergeArrays2D MainArray, ArrayOfArrays
    End If

End Sub

Private Sub MergeArrays2D(ByRef MainArray As Variant, ByRef ArrayOfArrays As Variant)

    Dim arrayOfColumnToReturn   As Variant
    Dim totRows                 As Long
    Dim row                     As Long
    Dim column                  As Long
    Dim resultRow               As Long
    Dim currentArray            As Variant
    Dim i                       As Long

    If Not IsArray(MainArray) Then Exit Sub
    arrayOfColumnToReturn = pColumnsToReturn

    ' If the caller don't pass the array of column to return
    ' create an array with all the columns and preserve the order
    If Not IsArray(arrayOfColumnToReturn) Then
        ReDim arrayOfColumnToReturn(LBound(MainArray, 2) To UBound(MainArray, 2))
        For column = LBound(MainArray, 2) To UBound(MainArray, 2)
            arrayOfColumnToReturn(column) = column
        Next column
    End If

    ' calculate dimensions of the result array
    totRows = UBound(MainArray)

    For row = LBound(ArrayOfArrays) To UBound(ArrayOfArrays)
        totRows = totRows + UBound(ArrayOfArrays(row)) - LBound(ArrayOfArrays(row)) + 1
    Next row

    ReDim tempArray(LBound(MainArray) To totRows, LBound(arrayOfColumnToReturn) To UBound(arrayOfColumnToReturn)) As Variant

    ' fill result array from main array
    For row = LBound(MainArray) To UBound(MainArray)
        For column = LBound(arrayOfColumnToReturn) To UBound(arrayOfColumnToReturn)
            tempArray(row, column) = MainArray(row, column)
        Next column
    Next row

    resultRow = row

    ' fill result array from ArrayOfArrays
    For i = LBound(ArrayOfArrays) To UBound(ArrayOfArrays)
        If IsArray(ArrayOfArrays(i)) Then
        currentArray = ArrayOfArrays(i)
        For row = LBound(currentArray) To UBound(currentArray)
            For column = LBound(arrayOfColumnToReturn) To UBound(arrayOfColumnToReturn)
                tempArray(resultRow, column) = currentArray(row, column)
            Next column
            resultRow = resultRow + 1
        Next row
        End If
    Next i

    MainArray = tempArray

End Sub

Private Sub MergeArrays1D(ByRef MainArray As Variant, ByRef ArrayOfArrays As Variant)

    Dim totRows                 As Long
    Dim row                     As Long
    Dim resultRow               As Long
    Dim currentArray            As Variant
    Dim i                       As Long

    If Not IsArray(MainArray) Then Exit Sub

    ' calculate dimensions of the result array
    totRows = UBound(MainArray)

    For row = LBound(ArrayOfArrays) To UBound(ArrayOfArrays)
        totRows = totRows + UBound(ArrayOfArrays(row)) - LBound(ArrayOfArrays(row)) + 1
    Next row

    ReDim tempArray(LBound(MainArray) To totRows) As Variant

    ' fill result array from main array
    For row = LBound(MainArray) To UBound(MainArray)
        tempArray(row) = MainArray(row)
    Next row

    resultRow = row

    ' fill result array from ArrayOfArrays
    For i = LBound(ArrayOfArrays) To UBound(ArrayOfArrays)
        If IsArray(ArrayOfArrays(i)) Then
        currentArray = ArrayOfArrays(i)
        For row = LBound(currentArray) To UBound(currentArray)
            tempArray(resultRow) = currentArray(row)
            resultRow = resultRow + 1
        Next row
        End If
    Next i

    MainArray = tempArray

End Sub

' SORT ****************************************************************************************

Public Sub Sort(ByRef myArray As Variant, Optional ByVal columnToSort As Long, _
                Optional Ascending As Boolean = True)

    If Not IsArray(myArray) Then Exit Sub

    If isSingleDimensionalArray(myArray) Then
        Divide1D myArray, Ascending
    Else
        Divide2D myArray, columnToSort, Ascending
    End If

End Sub

Private Sub Divide1D(thisArray As Variant, _
                     Optional Ascending As Boolean = True)

    Dim Length              As Long
    Dim i                   As Long

    Length = UBound(thisArray) - LBound(thisArray)
    If Length < 1 Then Exit Sub

    Dim Pivot               As Long
    Pivot = Length / 2

    ReDim leftArray(Pivot) As Variant
    ReDim rightArray(Length - Pivot - 1) As Variant

    Dim Index               As Long

    For Index = LBound(thisArray) To Pivot + LBound(thisArray)
        leftArray(i) = thisArray(Index)
        i = i + 1
    Next Index

    i = 0
    For Index = Index To UBound(thisArray)
        rightArray(i) = thisArray(Index)
        i = i + 1
    Next Index

    Divide1D leftArray
    Divide1D rightArray
    Merge1D leftArray, rightArray, thisArray, Ascending

End Sub

Private Sub Merge1D(leftArray As Variant, rightArray As Variant, _
                    arrayToSort As Variant, Ascending As Boolean)

    Dim lLength             As Long
    Dim rLength             As Long
    Dim leftLowest          As Long
    Dim rightLowest         As Long
    Dim resultIndex         As Long

    resultIndex = IIf(Ascending, LBound(arrayToSort), UBound(arrayToSort))

    lLength = UBound(leftArray)
    rLength = UBound(rightArray)

    Do While leftLowest <= lLength And rightLowest <= rLength
        If leftArray(leftLowest) <= rightArray(rightLowest) Then
            arrayToSort(resultIndex) = leftArray(leftLowest)
            leftLowest = leftLowest + 1
        Else
            arrayToSort(resultIndex) = rightArray(rightLowest)
            rightLowest = rightLowest + 1
        End If
        resultIndex = resultIndex + IIf(Ascending, 1, -1)
    Loop

    Do While leftLowest <= lLength
        arrayToSort(resultIndex) = leftArray(leftLowest)
        leftLowest = leftLowest + 1
        resultIndex = resultIndex + IIf(Ascending, 1, -1)
    Loop

    Do While rightLowest <= rLength
        arrayToSort(resultIndex) = rightArray(rightLowest)
        rightLowest = rightLowest + 1
        resultIndex = resultIndex + IIf(Ascending, 1, -1)
    Loop

End Sub

Private Sub Divide2D(thisArray As Variant, ByRef columnToSort As Long, _
                     Optional Ascending As Boolean = True)

    Dim Length              As Long
    Dim firstColumn         As Long
    Dim lastColumn          As Long
    Dim column              As Long
    Dim i                   As Long

    firstColumn = LBound(thisArray, 2)
    lastColumn = UBound(thisArray, 2)
    Length = UBound(thisArray) - LBound(thisArray)
    If Length < 1 Then Exit Sub

    Dim Pivot               As Long
    Pivot = Length / 2

    ReDim leftArray(0 To Pivot, firstColumn To lastColumn) As Variant
    ReDim rightArray(0 To Length - Pivot - 1, firstColumn To lastColumn) As Variant

    Dim Index               As Long

    For Index = LBound(thisArray) To Pivot + LBound(thisArray)
        For column = firstColumn To lastColumn
            leftArray(i, column) = thisArray(Index, column)
        Next column
        i = i + 1
    Next Index

    i = 0

    For Index = Index To UBound(thisArray)
        For column = firstColumn To lastColumn
            rightArray(i, column) = thisArray(Index, column)
        Next column
        i = i + 1
    Next Index

    Divide2D leftArray, columnToSort
    Divide2D rightArray, columnToSort
    Merge2D leftArray, rightArray, thisArray, Ascending, columnToSort

End Sub

Private Sub Merge2D(leftArray As Variant, rightArray As Variant, _
                    arrayToSort As Variant, Ascending As Boolean, ByRef columnToSort As Long)

    Dim lLength             As Long
    Dim rLength             As Long
    Dim leftLowest          As Long
    Dim rightLowest         As Long
    Dim resultIndex         As Long
    Dim firstColumn         As Long
    Dim lastColumn          As Long
    Dim column              As Long

    resultIndex = IIf(Ascending, LBound(arrayToSort), UBound(arrayToSort))

    firstColumn = LBound(arrayToSort, 2)
    lastColumn = UBound(arrayToSort, 2)
    leftLowest = LBound(leftArray)
    rightLowest = LBound(rightArray)
    lLength = UBound(leftArray)
    rLength = UBound(rightArray)

    Do While leftLowest <= lLength And rightLowest <= rLength
        If leftArray(leftLowest, columnToSort) <= rightArray(rightLowest, columnToSort) Then
            For column = firstColumn To lastColumn
                arrayToSort(resultIndex, column) = leftArray(leftLowest, column)
            Next column
            leftLowest = leftLowest + 1
        Else
            For column = firstColumn To lastColumn
                arrayToSort(resultIndex, column) = rightArray(rightLowest, column)
            Next column
            rightLowest = rightLowest + 1
        End If
        resultIndex = resultIndex + IIf(Ascending, 1, -1)
    Loop

    Do While leftLowest <= lLength
        For column = firstColumn To lastColumn
            arrayToSort(resultIndex, column) = leftArray(leftLowest, column)
        Next column
        leftLowest = leftLowest + 1
        resultIndex = resultIndex + IIf(Ascending, 1, -1)
    Loop

    Do While rightLowest <= rLength
        For column = firstColumn To lastColumn
            arrayToSort(resultIndex, column) = rightArray(rightLowest, column)
        Next column
        rightLowest = rightLowest + 1
        resultIndex = resultIndex + IIf(Ascending, 1, -1)
    Loop

End Sub

EDIT: Correct an error on filter 1D subroutine

\$\endgroup\$
3
\$\begingroup\$

The first comment has to do with your question about Results. IMO you are far better off to implement your ArrayToX and XToArray subroutines as functions. Also, I tried to use your module (Class Module or Standard Module? => recommend ClassModule) and had difficulty understanding how to use the Filters. In fact, I never did figure it out. I wrote a test subroutine in a Standard Module to try and use the code. (I would suggest you could improve your question by providing a similar example of how the class is intended to be used.)

Here's the test subroutine I was working with:

Option Explicit 

Public Sub Test()
  Dim testObject As ArrayOps
  Set testObject = New ArrayOps

  Dim arrayOfNumbers(12)
  Dim numbers As Long
  For numbers = 0 To 11
     arrayOfNumbers(numbers) = numbers
  Next

  Dim result As String
  testObject.ArrayToString arrayOfNumbers, result

  Dim result2 As String
  result2 = testObject.ArrayToString2(arrayOfNumbers)

  Dim result3 As String
  result3 = testObject.ArrayToString2(arrayOfNumbers, testObject.FilterIncludeEquals2(3, 0))

End Sub

The first use of ArrayToString is the version in the posted code. I've added some functions to your module to support the code for result2 and result3.

To my eye, the code reads easier using Functions rather than Subroutines. Also, using ByRef to allow passed-in values to change is probably not the best practice - especially for arrays. As the user, I probably do not want to pass in an array and get back a modified version. The user might have wanted to retain the original array for other downstream logic. Using a Function will make the input versus output very clear.

The code for the added ArrayToString2 and FilterIncludeEquals2 are basically copies of the original Subroutine with some edits and comments. They are:

    Public Function ArrayToString2(ByRef originalArray As Variant, Optional filter As Collection = Nothing, _
                         Optional colSeparator As String = ",", Optional rowSeparator As String = ";") As String

        Dim firstRow        As Long
        Dim lastRow         As Long
        Dim firstColumn     As Long
        Dim lastColumn      As Long
        Dim row             As Long
        Dim col             As Long

        If Not IsArray(originalArray) Then Exit Function

        ' Join single dimension array
        If isSingleDimensionalArray(originalArray) Then
            ArrayToString2 = Join(originalArray, colSeparator)
            If Not filter Is Nothing Then
                ArrayToString2 = FilterApplyTo2(ArrayToString2)
            End If

            Exit Function
        End If

        firstRow = LBound(originalArray, 1)
        lastRow = UBound(originalArray, 1)
        firstColumn = LBound(originalArray, 2)
        lastColumn = UBound(originalArray, 2)

        'No need to use module variables - locals would be better
        Dim rowArray As Variant
        ReDim rowArray(firstRow To lastRow) As Variant

        Dim tempArray As Variant
        ReDim tempArray(firstColumn To lastColumn)

        For row = firstRow To lastRow
            ' fill array with values of the entire row
            For col = firstColumn To lastColumn
                tempArray(col) = originalArray(row, col)
            Next col
            rowArray(row) = Join(tempArray, colSeparator)
        Next row

        ' convert rowArray to string
        ArrayToString2 = Join(rowArray, rowSeparator)

        If Not filter Is Nothing Then
            ArrayToString2 = FilterApplyTo2(ArrayToString2)
        End If

        'Now using local variables
        'Erase rowArray
        'Erase tempArray

    End Function

    Public Function FilterIncludeEquals2(ByRef equalTo As Variant, ByRef inColumn As Long, _
                             Optional ByRef isCaseSensitive As Boolean = False) As Collection
       'Declaring thisFilter outside the If block so that the function always returns a
       'collection (possibly empty) rather than nothing 
        Dim thisFilter  As Collection
        Set thisFilter = New Collection
        'There's an upper limit to check for as well since only 1 and 2 dimensional
        'arrays are handled?
        If inColumn > -1 And inColumn < 2 Then

            'Dim thisFilter              As Collection
            'Dim thisFilterType          As filterType

            'Set thisFilter = New Collection
            'thisFilterType = exactMatch

            With thisFilter
                .Add exactMatch
                .Add inColumn
                .Add IIf(isCaseSensitive, equalTo, LCase(equalTo))
                .Add isCaseSensitive
            End With

            'To use this filter as a parameter in ArrayToString2 I return it directly.
            'This is different than the original design...just an example to consider 
            'If pFiltersCollection Is Nothing Then Set pFiltersCollection = New Collection

            'pFiltersCollection.Add thisFilter
            'Set thisFilter = Nothing
        End If
        Set FilterIncludeEquals2 = thisFilter

    End Function

Based on your update, I better understand what you are working toward - thanks! After looking at your example, I would suggest that there is a definite advantage to creating a class module for the filter operations. Establish a "Filter" Property in the ArrayManipulation class. You mention concerns that adding a second module would possibly confusing to the user. IMO it creates less confusion.

Below is another version of the test module with a revised Test Subroutine using the ArrayManipulation class with an ArrayManipulationFilter class member available as Public Property Get Filter().

    Option Explicit

    Public Sub Test()

        Dim testObject As ArrayManipulation
        Set testObject = New ArrayManipulation

        Dim arrayOfNumbers As Variant
        ReDim arrayOfNumbers(12)
        Dim numbers As Long
        For numbers = 0 To 11
           arrayOfNumbers(numbers) = numbers
        Next

        Dim arrayReturned As Variant
        With testObject
            ' setup filters
            .Filter.ExcludeEquals 3, 0
            .Filter.IncludeIfBetween 1, 4, 0

            ' this create a txt file storing the array

            ' The filter can now be applied inline or separately.
            ' Or, "applyFilters As Boolean" can also be added as a parameter to the ArrayToX subroutine signatures
            .ArrayToTextFile .Filter.ApplyTo(arrayOfNumbers), Environ("USERPROFILE") & "\Desktop\Test.txt"

            ' this read the array from the just created file
            .TextFileToArray Environ("USERPROFILE") & "\Desktop\Test.txt", arrayReturned

            ' this write the array on activesheet of you activeworkbook, starting from D3
            'arrayOfNumbers is still the original set of numbers
            .ArrayToRange arrayOfNumbers, Cells(3, 4)
            .ArrayToRange arrayReturned, Cells(5, 4)
        End With

    End Sub

Below is the ArrayManipulationFilter class which was a copy of the filter subroutines from the original class (with the "Filter" prefix removed from the subroutine names) plus the additional code below.

    Private Sub Class_Initialize()
        Set pFiltersCollection = New Collection
    End Sub

    Public Function ApplyTo(ByRef originalArray As Variant) As Variant

        If Not IsArray(originalArray) Then Exit Function

        Dim result As Variant
        If isSingleDimensionalArray(originalArray) Then
            ApplyTo = filter1DArray(originalArray)
        Else
            ApplyTo = filter2DArray(originalArray)
        End If

    End Function

    Private Function isSingleDimensionalArray(myArray As Variant) As Boolean

        Dim testDimension As Long

        testDimension = -1
        On Error Resume Next
        testDimension = UBound(myArray, 2)
        On Error GoTo 0
        isSingleDimensionalArray = (testDimension = -1)

    End Function

    Private Function filter2DArray(ByRef originalArray As Variant) As Variant

        Dim firstRow                    As Long
        Dim lastRow                     As Long
        Dim firstColumn                 As Long
        Dim lastColumn                  As Long
        Dim row                         As Long
        Dim col                         As Long
        Dim arrayOfColumnToReturn       As Variant
        Dim partialMatchColumnsArray    As Variant
        Dim result                      As Variant

        result = -1
        arrayOfColumnToReturn = pColumnsToReturn
        If Not pPartialMatchColl Is Nothing Then partialMatchColumnsArray = pPartialMatchColl(2)

        ' If the caller don't pass the array of column to return
        ' create an array with all the columns and preserve the order
        If Not IsArray(arrayOfColumnToReturn) Then
            ReDim arrayOfColumnToReturn(LBound(originalArray, 2) To UBound(originalArray, 2))
            For col = LBound(originalArray, 2) To UBound(originalArray, 2)
                arrayOfColumnToReturn(col) = col
            Next col
        End If

        ' If the caller don't pass an array for partial match
        ' check if it pass the special value 1, if true the
        ' partial match will be performed on values in columns to return
        If Not IsArray(partialMatchColumnsArray) Then
            If partialMatchColumnsArray = 1 Then partialMatchColumnsArray = arrayOfColumnToReturn
        End If

        firstRow = LBound(originalArray, 1)
        lastRow = UBound(originalArray, 1)

        ' main loop
        Dim keepCount           As Long
        Dim Filter              As Variant
        Dim currentFilterType   As filterType

        ReDim arrayOfRowsToKeep(lastRow - firstRow + 1) As Variant
        keepCount = 0

        For row = firstRow To lastRow

            ' exact, excluse and between checks
            If Not pFiltersCollection Is Nothing Then
                For Each Filter In pFiltersCollection
                    currentFilterType = Filter(1)
                    Select Case currentFilterType
                        Case negativeMatch
                            If Filter(4) Then
                                If originalArray(row, Filter(2)) = Filter(3) Then GoTo Skip
                            Else
                                If LCase(originalArray(row, Filter(2))) = Filter(3) Then GoTo Skip
                            End If
                        Case exactMatch
                            If Filter(4) Then
                                If originalArray(row, Filter(2)) <> Filter(3) Then GoTo Skip
                            Else
                                If LCase(originalArray(row, Filter(2))) <> Filter(3) Then GoTo Skip
                            End If
                        Case isBetween
                            If originalArray(row, Filter(2)) < Filter(3) _
                            Or originalArray(row, Filter(2)) > Filter(4) Then GoTo Skip
                    End Select
                Next Filter
            End If

            ' partial match check
            If Not pPartialMatchColl Is Nothing Then
                If IsArray(partialMatchColumnsArray) Then
                    For col = LBound(partialMatchColumnsArray) To UBound(partialMatchColumnsArray)
                        If InStr(1, originalArray(row, partialMatchColumnsArray(col)), pPartialMatchColl(3), vbTextCompare) > 0 Then
                            GoTo Keep
                        End If
                    Next
                    GoTo Skip
                End If
            End If
    Keep:
            arrayOfRowsToKeep(keepCount) = row
            keepCount = keepCount + 1
    Skip:
        Next row

        ' create results array
        If keepCount > 0 Then

            firstRow = LBound(originalArray, 1)
            lastRow = LBound(originalArray, 1) + keepCount - 1
            firstColumn = LBound(originalArray, 2)
            lastColumn = LBound(originalArray, 2) + UBound(arrayOfColumnToReturn) - LBound(arrayOfColumnToReturn)

            ReDim result(firstRow To lastRow, firstColumn To lastColumn)

            For row = firstRow To lastRow
                For col = firstColumn To lastColumn
                    result(row, col) = originalArray(arrayOfRowsToKeep(row - firstRow), arrayOfColumnToReturn(col - firstColumn + LBound(arrayOfColumnToReturn)))
                Next col
            Next row

        End If

        filter2DArray = result
        If IsArray(result) Then Erase result

    End Function

    Private Function filter1DArray(ByRef originalArray As Variant) As Variant

        Dim firstRow                    As Long
        Dim lastRow                     As Long
        Dim firstColumn                 As Long
        Dim lastColumn                  As Long
        Dim row                         As Long
        Dim col                         As Long
        Dim arrayOfColumnToReturn       As Variant
        Dim partialMatchColumnsArray    As Variant
        Dim result                      As Variant

        result = -1

        firstRow = LBound(originalArray)
        lastRow = UBound(originalArray)

        ' main loop
        Dim keepCount           As Long
        Dim Filter              As Variant
        Dim currentFilterType   As filterType

        ReDim arrayOfRowsToKeep(lastRow - firstRow + 1) As Variant
        keepCount = 0

        For row = firstRow To lastRow

            ' exact, excluse and between checks
            If Not pFiltersCollection Is Nothing Then
                For Each Filter In pFiltersCollection
                    currentFilterType = Filter(1)
                    Select Case currentFilterType
                        Case negativeMatch
                            If Filter(4) Then
                                If originalArray(row) = Filter(3) Then GoTo Skip
                            Else
                                If LCase(originalArray(row)) = Filter(3) Then GoTo Skip
                            End If
                        Case exactMatch
                            If Filter(4) Then
                                If originalArray(row) <> Filter(3) Then GoTo Skip
                            Else
                                If LCase(originalArray(row)) <> Filter(3) Then GoTo Skip
                            End If
                        Case isBetween
                            If originalArray(row) < Filter(3) _
                            Or originalArray(row) > Filter(4) Then GoTo Skip
                    End Select
                Next Filter
            End If

            ' partial match check
            If Not pPartialMatchColl Is Nothing Then
                If InStr(1, originalArray(row), pPartialMatchColl(3), vbTextCompare) > 0 Then
                    GoTo Keep
                End If
                GoTo Skip
            End If
    Keep:
            arrayOfRowsToKeep(keepCount) = row
            keepCount = keepCount + 1
    Skip:
        Next row

        ' create results array
        If keepCount > 0 Then

            firstRow = LBound(originalArray, 1)
            lastRow = LBound(originalArray, 1) + keepCount - 1

            ReDim result(firstRow To lastRow)

            For row = firstRow To lastRow
                result(row) = originalArray(arrayOfRowsToKeep(row - firstRow))
            Next row

        End If

        filter1DArray = result
        If IsArray(result) Then Erase result

    End Function
| improve this answer | |
\$\endgroup\$
  • \$\begingroup\$ Hey BZngr! Thank you for your feedback.. You're right I'll modify all the routine to function... I've modified your test code to show how to use filter and other function \$\endgroup\$ – porkaloca Mar 5 at 14:07
  • \$\begingroup\$ I've modified the answer content based on your test code example. Thanks for providing it. \$\endgroup\$ – BZngr Mar 6 at 4:05
  • \$\begingroup\$ Thanks to you for the effort! I've seen your update, and I'm working to rewrite the code for the best result.. I'll wait 2 more days for other answers and then I'll accept your. Thank you! \$\endgroup\$ – porkaloca Mar 6 at 14:16

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.