2
\$\begingroup\$

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
\$\endgroup\$
1
\$\begingroup\$

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
\$\endgroup\$
1
  • \$\begingroup\$ 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.. \$\endgroup\$
    – DT1
    Feb 18 at 14:37

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.