So, after this functional(?) approach and thanks to the great improvement of @CDP1802, I've decided to try an OOP approach to filtering an two-dimensional array.
In my opinion, the result is way more elegant and has also performance improvements.
Now the user is able to choose the order of the filters (the more exclusive the first you set it) and can add how many filters he wants. He also can decide the columns to return and the order of the columns and, last, he can decide if comparison is case sensitive or not.
The array maintains the original's array base.
Do you like it? See possible improvements?
This was the old call method:
arr = FilterArray(arr1, , , , , , 2, "B2", , , , , , , , , , , , , , , , , , 1, True, #1/1/2010#, #1/1/2020#)
and this the new:
Dim f As ArrayFilter
Set f = New ArrayFilter
With f
.IncludeEquals "b2", 2
.IncludeBetween #1/1/2010#, #1/1/2020#, 1
.ApplyTo arr1
End With
This is the code of the ArrayFilter Class
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
Public Property Get Filters() As Collection
Set Filters = pFiltersCollection
End Property
Public Sub IncludeEquals(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 ExcludeEquals(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 IncludeBetween(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 IncludeIfContain(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 ApplyTo(ByRef originalArray As Variant)
If Not IsArray(originalArray) Then Exit Sub
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 Me.Filters Is Nothing Then
For Each filter In Me.Filters
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
