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
1 Answer 1
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
-
\$\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\$DT1– DT12020年03月05日 14:07:14 +00:00Commented Mar 5, 2020 at 14:07
-
\$\begingroup\$ I've modified the answer content based on your test code example. Thanks for providing it. \$\endgroup\$BZngr– BZngr2020年03月06日 04:05:41 +00:00Commented 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\$DT1– DT12020年03月06日 14:16:49 +00:00Commented Mar 6, 2020 at 14:16