OOP approach to filter two-dimensional array

Question

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

Answer 1

The code breaks at .Applyto with the following error:

Run-time error "458"
Variable uses an Automation type not supported in Visual Basic.

I passed a worksheet range to an Array and this, by definition, creates a 2D array. Here is my testing code.

Note: I verified that arr1 gets allocated with the passed Range.

Dim arr1() As Variant
arr1 = Range("B2:F5")
Dim Destination As Range
Set Destination = Range("K1")
Dim f As ArrayFilt
Set f = New ArrayFilt
With f
 .IncludeEquals "s", 2
 .ApplyTo arr1
End With
'more code to write the filtered array back to worksheet to check if the filter was correctly applied.
End Sub

• DT1: Hi @seeker.. This is old code and I'm sure there were some problems, but in this case, I can't reproduce the error you're pointing out.. When I copy and run the code above, no errors are raised and the filter works smoothly.. I can't help you..