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

asked Mar 5, 2020 at 2:22
\$\endgroup\$

1 Answer 1

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
answered Mar 5, 2020 at 7:47
\$\endgroup\$
3
  • \$\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\$ Commented Mar 5, 2020 at 14:07
  • \$\begingroup\$ I've modified the answer content based on your test code example. Thanks for providing it. \$\endgroup\$ Commented Mar 6, 2020 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\$ Commented Mar 6, 2020 at 14:16

Your Answer

Draft saved
Draft discarded

Sign up or log in

Sign up using Google
Sign up using Email and Password

Post as a guest

Required, but never shown

Post as a guest

Required, but never shown

By clicking "Post Your Answer", you agree to our terms of service and acknowledge you have read our privacy policy.

Start asking to get answers

Find the answer to your question by asking.

Ask question

Explore related questions

See similar questions with these tags.