5
\$\begingroup\$

Premise

I have written a function in VBA, called FILTER_RANGE(), which accepts a Range object and a filtration parameter. Unlike the existing FILTER() function, this FILTER_RANGE() will return a Range object: the subset of the original Range that was preserved by the filter.

"Filtering a Range"

To clarify what I mean by "filter a range and return a range", consider the following illustrations.

Rectangular Ranges

Here is a range named Rectangular (in red), which is a simple rectangle:

2

I can filter Rectangular by row...

' ...using a literal array...
= FILTER_RANGE(Rectangular, {FALSE; FALSE; FALSE; FALSE; TRUE; TRUE; TRUE; TRUE; TRUE; TRUE})

' ...a logical array...
= FILTER_RANGE(Rectangular, F4:F13 >= 5)

' ...or a range containing Boolean values.
= FILTER_RANGE(Rectangular, G4:G13)

...and return the filtered Range object itself...

3

...rather than an array of its (blank) values as returned by FILTER().

4

My code also supports filtering by column:

5

In the future, I hope to filter simultaneously by both row and column:

6

Irregular Ranges

My function can also do the same for irregular ranges, like Irregular (in blue):

7

Here are illustrated filtration by row...

8

...filtration by column...

9

...and simultaneous filtration by both row and column (not implemented yet):

10


Features

Analogously to FILTER(), I have designed FILTER_RANGE() to be of the form

FILTER_RANGE(range, include, [by_column], [if_empty])

where we have

  • range: an arbitrary Range object to be filtered. May be a standard range like B4:D14, or a named range like Irregular.
  • include: a set of logical filtration criteria, corresponding in size to range. May be a Boolean array, as with F4:F13 >= 5; or a Range containing Boolean values, as with G4:G14. Alternatively a Boolean scalar: TRUE to include everything; FALSE to exclude everything.
  • by_column: Optional. A Boolean scalar: TRUE to filter by column, and FALSE to filter by row. Defaults to FALSE for rowwise filtration.
  • if_empty: Optional. A Range object, which should be returned, rather than throwing an error, when the filter returns nothing (not implemented yet).

For additional context, when I add simultaneous filtration, the following form might apply instead:

FILTER_RANGE(range, include_rows, [include_columns], [if_empty])
  • range
  • include_rows: an independent set of logical filtration criteria for the rows in range.
  • include_columns: Optional. An independent set of logical filtration criteria for the columns in range. Defaults to TRUE to include all columns.
  • if_empty

Working Solution

My current working solution

FILTER_RANGE(range, include, [by_column])

achieves most Features described in the first form above, for "rectangular" and "irregular" ranges alike. The only missing features are:

  • the optional [if_empty] parameter, which is not yet implemented; and
  • simultaneous filtration, which would have the differing form of FILTER_RANGE(range, include_rows, [include_columns], [if_empty]).

Suggestions

In my Code shown below, I suspect there are a few opportunities for improvement:

  • The FILTER_RANGE_BY_ROW() function uses COUNT_ALL_ROWS() to validate the dimensions, before calling GET_ALL_ROWS() later on. However, COUNT_ALL_ROWS() itself uses GET_ALL_ROWS(), so this code is redundant. Likewise for FILTER_RANGE_BY_COLUMN() with COUNT_ALL_COLUMNS() and GET_ALL_COLUMNS().
  • The algorithms are currently iterative. I would prefer a more efficient solution in the spirit of R, where vectorization is superior to looping.
  • The algorithms currently iterate over every .EntireRow (or .EntireColumn) of every area in range. I would prefer to iterate directly over every unique row (or column) in range, without having to first consolidate (via Application.Union()) the rows (or columns) from every area.
  • Those algorithms safeguard against doubly counting cells in overlapping areas like those (dark blue) in Irregular (below). However, in large areas with dense overlap, this approach could iterate redundantly over each of a thousand cells, and the performance would bog down. 7

Code

I have divided the code between "Exposed Functions" for normal use, and the "Helper Functions" that support them.

Exposed Functions

' Filter a range and return it by reference rather than value.
Public Function FILTER_RANGE(range As range, include As Variant, Optional by_column As Boolean = False) As range
    ' Coerce filter from range to array, if necessary.
    If TypeOf include Is range Then
        include = RANGE_TO_ARRAY(include)
    End If
    
    ' Dispatch to helper functions, which filter by row or column as desired.
    If by_column Then
        Set FILTER_RANGE = FILTER_RANGE_BY_COLUMNS(range, include)
    Else
        Set FILTER_RANGE = FILTER_RANGE_BY_ROWS(range, include)
    End If
End Function


' Extract as text the full address for a given range.  Used in Excel to validate the results from FILTER_RANGE().
Public Function RANGE_ADDRESS(range As range) As String
    If range Is Nothing Then
        RANGE_ADDRESS = ""
    ' ElseIf range Is Null Then
    '     RANGE_ADDRESS = ""
    Else
        RANGE_ADDRESS = range.Address
    End If
End Function

Helper Functions

' .
Public Function COUNT_ALL_ROWS(range As range, Optional unique As Boolean = True) As LongLong
    Dim consolidatedRows As range
    
    COUNT_ALL_ROWS = 0
    Set consolidatedRows = Nothing
    
    ' Consolidate all relevant rows as desired.
    If unique Then
        Set consolidatedRows = GET_ALL_ROWS(range)
    Else
        Set consolidatedRows = range
    End If
    
    ' Count the rows.
    For Each area In consolidatedRows.Areas
        COUNT_ALL_ROWS = COUNT_ALL_ROWS + area.rows.CountLarge
    Next
End Function

' .
Public Function COUNT_ALL_COLUMNS(range As range, Optional unique As Boolean = True) As LongLong
    Dim consolidatedColumns As range
    
    COUNT_ALL_COLUMNS = 0
    Set consolidatedColumns = Nothing
    
    ' Consolidate all relevant columns as desired.
    If unique Then
        Set consolidatedColumns = GET_ALL_COLUMNS(range)
    Else
        Set consolidatedColumns = range
    End If
    
    ' Count the columns.
    For Each area In consolidatedColumns.Areas
        COUNT_ALL_COLUMNS = COUNT_ALL_COLUMNS + area.Columns.CountLarge
    Next
End Function

' .
Private Function FILTER_RANGE_BY_ROWS(range As range, include As Variant) As range
    ' Capture the sizes of the range and the filtering array.
    rangeSize = COUNT_ALL_ROWS(range, True)
    
    ' Check if the filter is an array or a scalar.
    filterIsArray = IsArray(include)
    
    ' Proceed as normal if the filter is an array...
    If filterIsArray Then
        filterSize = GET_ARRAY_LENGTH(include)
    ' ...or throw an error if the filter is not a boolean scalar...
    ElseIf VarType(include) <> vbBoolean Then
        Err.Raise vbObjectError + 513
    ' ...and otherwise return an empty range if the scalar (False) excludes everything...
    ElseIf include = False Then
        Set FILTER_RANGE_BY_ROWS = Nothing
        Exit Function
    ' ...or return the original range if the scalar (True) includes everything.
    ElseIf include = True Then
        Set FILTER_RANGE_BY_ROWS = range
        Exit Function
    End If
    
    ' Throw an error if that filter is an array that does not correspond in size to the range.
    If (rangeSize <> filterSize) And filterIsArray Then
        Err.Raise vbObjectError + 513
    End If
    
    ' Prepare iterators.
    Dim filterIndex As Integer
    filterIndex = 0
    
    Dim rangeRows As range
    Set rangeRows = GET_ALL_ROWS(range)
    
    Set FILTER_RANGE_BY_ROWS = Nothing
    
    ' Iterate over every distinct row:
    For Each area In rangeRows.Areas
        For Each singleRow In area.rows
            ' Increment the index.
            filterIndex = filterIndex + 1
            
            ' If the corresponding filter value is TRUE, then keep this row.
            If include(filterIndex, 1) = True Then
                If FILTER_RANGE_BY_ROWS Is Nothing Then
                    Set FILTER_RANGE_BY_ROWS = singleRow
                Else
                    Set FILTER_RANGE_BY_ROWS = Application.Union(FILTER_RANGE_BY_ROWS, singleRow)
                End If
            End If
        Next
    Next
    
    ' Keep the range that overlaps with the rows that were kept.
    If FILTER_RANGE_BY_ROWS Is Nothing Then
        Set FILTER_RANGE_BY_ROWS = Nothing
    Else
        Set FILTER_RANGE_BY_ROWS = Application.Intersect(range, FILTER_RANGE_BY_ROWS)
    End If
End Function

' .
Private Function FILTER_RANGE_BY_COLUMNS(range As range, include As Variant) As range
    ' Capture the sizes of the range and the filtering array.
    rangeSize = COUNT_ALL_COLUMNS(range, True)
    
    ' Check if the filter is an array or a scalar.
    filterIsArray = IsArray(include)
    
    ' Proceed as normal if the filter is an array...
    If filterIsArray Then
        filterSize = GET_ARRAY_LENGTH(include)
    ' ...or throw an error if the filter is not a boolean scalar...
    ElseIf VarType(include) <> vbBoolean Then
        Err.Raise vbObjectError + 513
    ' ...and otherwise return an empty range if the scalar (False) excludes everything...
    ElseIf include = False Then
        Set FILTER_RANGE_BY_COLUMNS = Nothing
        Exit Function
    ' ...or return the original range if the scalar (True) includes everything.
    ElseIf include = True Then
        Set FILTER_RANGE_BY_COLUMNS = range
        Exit Function
    End If
    
    ' Throw an error if that filter is an array that does not correspond in size to the range.
    If (rangeSize <> filterSize) And filterIsArray Then
        Err.Raise vbObjectError + 513
    End If
    
    ' Prepare iterators.
    Dim filterIndex As Integer
    filterIndex = 0
    
    Dim rangeColumns As range
    Set rangeColumns = GET_ALL_COLUMNS(range)
    
    Set FILTER_RANGE_BY_COLUMNS = Nothing
    
    ' Iterate over every distinct column:
    For Each area In rangeColumns.Areas
        For Each singleColumn In area.Columns
            ' Increment the index.
            filterIndex = filterIndex + 1
            
            ' If the corresponding filter value is TRUE, then keep this column.
            If include(filterIndex, 1) = True Then
                If FILTER_RANGE_BY_COLUMNS Is Nothing Then
                    Set FILTER_RANGE_BY_COLUMNS = singleColumn
                Else
                    Set FILTER_RANGE_BY_COLUMNS = Application.Union(FILTER_RANGE_BY_COLUMNS, singleColumn)
                End If
            End If
        Next
    Next
    
    ' Keep the range that overlaps with the columns that were kept.
    If FILTER_RANGE_BY_COLUMNS Is Nothing Then
        Set FILTER_RANGE_BY_COLUMNS = Nothing
    Else
        Set FILTER_RANGE_BY_COLUMNS = Application.Intersect(range, FILTER_RANGE_BY_COLUMNS)
    End If
End Function

' .
Private Function GET_ALL_ROWS(range As range) As range
    Set GET_ALL_ROWS = Nothing
    
    For Each area In range.Areas
        If GET_ALL_ROWS Is Nothing Then
            Set GET_ALL_ROWS = area.EntireRow
        Else
            Set GET_ALL_ROWS = Application.Union(GET_ALL_ROWS, area.EntireRow)
        End If
    Next
End Function

' .
Private Function GET_ALL_COLUMNS(range As range) As range
    Set GET_ALL_COLUMNS = Nothing
    
    For Each area In range.Areas
        If GET_ALL_COLUMNS Is Nothing Then
            Set GET_ALL_COLUMNS = area.EntireColumn
        Else
            Set GET_ALL_COLUMNS = Application.Union(GET_ALL_COLUMNS, area.EntireColumn)
        End If
    Next
End Function

' .
Private Function RANGE_TO_ARRAY(range As Variant) As Variant
    ' .
    RANGE_TO_ARRAY = range.Value2
    '                      |----|
    '                      Use ".Value2" for better performance.
End Function

' .
Private Function GET_ARRAY_LENGTH(a As Variant) As Integer
    If IsEmpty(a) Then
       GET_ARRAY_LENGTH = 0
    Else
       GET_ARRAY_LENGTH = UBound(a) - LBound(a) + 1
    End If
End Function
\$\endgroup\$
3
  • \$\begingroup\$ For reference: this code originated here, in answer to this question on Stack Overflow. \$\endgroup\$
    – Greg
    Jun 3 at 21:26
  • \$\begingroup\$ Thanks! But you haven't done the simultaneous filtration? \$\endgroup\$
    – Greedo
    Jun 3 at 21:40
  • 1
    \$\begingroup\$ @Greedo Correct, no simultaneous filtration. That would have a different form: FILTER_RANGE(range, include_rows, [include_columns]). \$\endgroup\$
    – Greg
    Jun 3 at 21:41

1 Answer 1

2
\$\begingroup\$

Function Over Form

I have improved on my working solution, and I can now achieve the simultaneous filtration described here:

For additional context, when I add simultaneous filtration, the following form might apply instead:

FILTER_RANGE(range, include_rows, [include_columns], [if_empty])

  • range
  • include_rows: an independent set of logical filtration criteria for the rows in range.
  • include_columns: Optional. An independent set of logical filtration criteria for the columns in range. Defaults to TRUE to include all columns.
  • if_empty

In order to optimize performance, I have implemented extensive conditionals to control the flow of execution and minimize expensive operations. Such conditionals were also necessary to systematically handle various quirks in VBA: especially the conversion of Ranges into arrays for include_rows and include_columns.

For better speed, I have separated include_rows(rowFilterIndex) and include_rows(rowFilterIndex, 1) and include_rows(1, rowFilterIndex) into three mutually exclusive loops over the three possible array structures; rather than conditioning on the array structure within a single loop, which would add a few more operations (conditions and array extraction) for each of potentially a million rows.

To conserve memory, I have also waited until absolutely necessary to initialize potentially large objects, so there are fewer (potentially) massive Range objects at once. Hence I write Set FILTER_RANGE = Nothing with a conditional Set FILTER_RANGE = range later on; rather than starting with Set FILTER_RANGE = range.

Limitations

Unfortunately, this optimization has come at a heavy cost to elegance. The code is rather daunting in size, and its logic can be difficult to follow. Fortunately, it has worked so far, and the end user in Excel need never peek "under the hood" in VBA.

At the moment, include_rows and include_columns will only work properly with contiguous ranges. Thus, we cannot define a noncontiguous range like $V$3:$V$6, $V$8:$V$10, $V$12:$V$15 (in purple), to serve as the include_rows filter for a range like Irregular (in blue): 1

Code

Exposed Functions

GET_RANGE_ADDRESS()

Extracts as a String the address for a given Range. Useful when testing FILTER_RANGE().

Public Function GET_RANGE_ADDRESS(range As range) As String
    If range Is Nothing Then
        GET_RANGE_ADDRESS = ""
    ' ElseIf range Is Null Then
    '     GET_RANGE_ADDRESS = ""
    Else
        GET_RANGE_ADDRESS = range.Address
    End If
End Function

FILTER_RANGE()

Filters a Range simultaneously by row and column; and returns the results by reference, as a subset of the original Range itself rather than as a mere array of its values.

Public Function FILTER_RANGE( _
    range As range, _
    Optional include_rows As Variant = True, _
    Optional include_columns As Variant = True, _
    Optional if_empty As range = Nothing _
) As range
    ' Validate the type and structure of the row filter.
    Dim rowFilterType As String
    rowFilterType = ""
    
    If IS_RANGE(include_rows) Then
        rowFilterType = "Range"
    ElseIf IS_BOOLEAN(include_rows) Then
        rowFilterType = "Boolean"
    ElseIf IS_ARRAY(include_rows) Then
        rowFilterType = "Array"
    Else
        ' ' For testing purposes.
        ' FILTER_RANGE = "INVALID!"
        ' Exit Function
        
        Err.Raise vbObjectError + 513
    End If
    
    Dim rowFilterDimensionCount As Long
    rowFilterDimensionCount = 0
    
    Dim rowFilterArrayOrientation As String
    rowFilterArrayOrientation = ""
    
    Dim rowFilterSize As Long
    rowFilterSize = 0
    
    ' Deal with any range:
    If rowFilterType = "Range" Then
        ' Coerce range to array.
        include_rows = RANGE_TO_ARRAY_1(include_rows)
        ' Count the dimensions in the array.
        rowFilterDimensionCount = COUNT_ARRAY_DIMENSIONS(include_rows)
        
        ' - Treat an "empty" array as a scalar...
        If rowFilterDimensionCount = 0 Then
            ' ...which either persists as a boolean...
            If IS_BOOLEAN(include_rows) Then
                rowFilterType = "Boolean"
                
                ' ' For testing purposes.
                ' FILTER_RANGE = "Range to Boolean Scalar: " & include_rows
                ' Exit Function
            ' ...or triggers an error for its irrelevant type.
            Else
                ' ' For testing purposes.
                ' FILTER_RANGE = "Range to INVALID Scalar: " & include_rows
                ' Exit Function
                
                Err.Raise vbObjectError + 513
            End If
        ' - Treat a vector as the vector it is.
        ElseIf rowFilterDimensionCount = 1 Then
            rowFilterSize = GET_ARRAY_LENGTH(include_rows, 1)
            
            rowFilterType = "Array"
            rowFilterArrayOrientation = "Vector"
            
            ' ' For testing purposes.
            ' FILTER_RANGE = "Range to Array with " & rowFilterDimensionCount & " Dimensions, the " & 1 & "th of which has length " & rowFilterSize
            ' Exit Function
        ' - Measure a rectangle by longest dimension, with the "column" (its 2nd dimension) as default.
        ElseIf rowFilterDimensionCount = 2 Then
            ' Default to the column dimension...
            rowFilterSize = GET_ARRAY_LENGTH(include_rows, 2)
            rowFilterType = "Array"
            rowFilterArrayOrientation = "Column"
            
            ' ...but still capture its row dimension...
            Dim rowFilterResize As Long
            rowFilterResize = GET_ARRAY_LENGTH(include_rows, 1)
            
            ' ...for comparison: the longest dimension should be used.
            If rowFilterSize < rowFilterResize Then
                rowFilterSize = rowFilterResize
                
                rowFilterArrayOrientation = "Row"
            
                ' ' For testing purposes.
                ' FILTER_RANGE = "Range to Array with " & rowFilterDimensionCount & " Dimensions, the " & 1 & "th of which has length " & rowFilterSize
                ' Exit Function
            Else
                ' ' For testing purposes.
                ' FILTER_RANGE = "Range to Array with " & rowFilterDimensionCount & " Dimensions, the " & 2 & "th of which has length " & rowFilterSize
                ' Exit Function
            End If
        ' - Throw an error for an array of 3+ dimensions.
        ElseIf rowFilterDimensionCount > 2 Then
            ' ' For testing purposes.
            ' FILTER_RANGE = "INVALID: Range to Array with " & rowFilterDimensionCount & " Dimensions!"
            ' Exit Function
            
            Err.Raise vbObjectError + 513
        End If
    ' Deal with any array structure:
    ElseIf rowFilterType = "Array" Then
        ' Count the dimensions in the array.
        rowFilterDimensionCount = COUNT_ARRAY_DIMENSIONS(include_rows)
        
        ' - Throw an error for an empty array.
        If rowFilterDimensionCount = 0 Then
            Err.Raise vbObjectError + 513
        ' - Treat a vector as the vector it is.
        ElseIf rowFilterDimensionCount = 1 Then
            rowFilterSize = GET_ARRAY_LENGTH(include_rows, 1)
            
            rowFilterArrayOrientation = "Vector"
            
            ' ' For testing purposes.
            ' FILTER_RANGE = "Array with " & rowFilterDimensionCount & " Dimensions, the " & 1 & "th of which has length " & rowFilterSize
            ' Exit Function
        ' - Measure a rectangle by its column, which is here the "row" (1st dimension) of the array.
        ElseIf rowFilterDimensionCount = 2 Then
            rowFilterSize = GET_ARRAY_LENGTH(include_rows, 1)
            
            rowFilterArrayOrientation = "Row"
            
            ' ' For testing purposes.
            ' FILTER_RANGE = "Array with " & rowFilterDimensionCount & " Dimensions, the " & 1 & "th of which has length " & rowFilterSize
            ' Exit Function
        ' - Throw an error for an array of 3+ dimensions.
        ElseIf rowFilterDimensionCount > 2 Then
            Err.Raise vbObjectError + 513
        End If
    ' Deal (inertly) with any boolean scalar.
    ElseIf rowFilterType = "Boolean" Then
        ' ' For testing purposes.
        ' FILTER_RANGE = "Boolean Scalar: " & include_rows
        ' Exit Function
    End If
    
    ' ' For testing purposes.
    ' FILTER_RANGE = "Valid..."
    ' Exit Function
    
    
    ' Validate the type and structure of the column filter.
    Dim columnFilterType As String
    columnFilterType = ""
    
    If IS_RANGE(include_columns) Then
        columnFilterType = "Range"
    ElseIf IS_BOOLEAN(include_columns) Then
        columnFilterType = "Boolean"
    ElseIf IS_ARRAY(include_columns) Then
        columnFilterType = "Array"
    Else
        Err.Raise vbObjectError + 513
    End If
    
    Dim columnFilterDimensionCount As Long
    columnFilterDimensionCount = 0
    
    Dim columnFilterArrayOrientation As String
    columnFilterArrayOrientation = ""
    
    Dim columnFilterSize As Long
    columnFilterSize = 0
    
    ' Deal with any range:
    If columnFilterType = "Range" Then
        include_columns = RANGE_TO_ARRAY_1(include_columns)
        columnFilterDimensionCount = COUNT_ARRAY_DIMENSIONS(include_columns)
        
        If columnFilterDimensionCount = 0 Then
            If IS_BOOLEAN(include_columns) Then
                columnFilterType = "Boolean"
            Else
                Err.Raise vbObjectError + 513
            End If
        ElseIf columnFilterDimensionCount = 1 Then
            columnFilterSize = GET_ARRAY_LENGTH(include_columns, 1)
            
            columnFilterType = "Array"
            columnFilterArrayOrientation = "Vector"
        ElseIf columnFilterDimensionCount = 2 Then
            columnFilterSize = GET_ARRAY_LENGTH(include_columns, 2)
            columnFilterType = "Array"
            columnFilterArrayOrientation = "Column"
            
            Dim columnFilterResize As Long
            columnFilterResize = GET_ARRAY_LENGTH(include_columns, 1)
            
            If columnFilterSize < columnFilterResize Then
                columnFilterSize = columnFilterResize

                columnFilterArrayOrientation = "Row"
            Else
                ' ...
            End If
        ElseIf columnFilterDimensionCount > 2 Then
            Err.Raise vbObjectError + 513
        End If
    ElseIf columnFilterType = "Array" Then
        columnFilterDimensionCount = COUNT_ARRAY_DIMENSIONS(include_columns)
        
        If columnFilterDimensionCount = 0 Then
            Err.Raise vbObjectError + 513
        ElseIf columnFilterDimensionCount = 1 Then
            columnFilterSize = GET_ARRAY_LENGTH(include_columns, 1)
            
            columnFilterArrayOrientation = "Vector"
        ElseIf columnFilterDimensionCount = 2 Then
            columnFilterSize = GET_ARRAY_LENGTH(include_columns, 1)
            
            columnFilterArrayOrientation = "Column"
        ElseIf columnFilterDimensionCount > 2 Then
            Err.Raise vbObjectError + 513
        End If
    ElseIf columnFilterType = "Boolean" Then
        ' ...
    End If
    
    
    ' Get and count all distinct rows and columns present in the range.
    Dim allRows As range
    Set allRows = GET_ALL_ROWS(range)
    
    Dim rowCount As Long
    rowCount = COUNT_ALL_ROWS(allRows, False)
    '                                  |---|
    ' Since the rows are already distinct, don't bother deduplicating them...
    
    Dim allColumns As range
    Set allColumns = GET_ALL_COLUMNS(range)
    
    Dim columnCount As Long
    columnCount = COUNT_ALL_COLUMNS(allColumns, False)
    '                                           |---|
    '                ...and likewise for the columns.
    
    
    ' Throw an error for array filters that fail to match the range in size.
    If rowFilterType = "Array" And (rowFilterSize <> rowCount) Then
        Err.Raise vbObjectError + 513
    ElseIf columnFilterType = "Array" And (columnFilterSize <> columnCount) Then
        Err.Raise vbObjectError + 513
    End If
    
    
    ' Check if the either filter is a blanket inclusion or exclusion.
    Dim rowBlanket As String
    If rowFilterType = "Boolean" Then
        If include_rows Then
            rowBlanket = "Include"
        Else
            rowBlanket = "Exclude"
        End If
    Else
        rowBlanket = ""
    End If
    
    Dim columnBlanket As String
    If columnFilterType = "Boolean" Then
        If include_columns Then
            columnBlanket = "Include"
        Else
            columnBlanket = "Exclude"
        End If
    Else
        columnBlanket = ""
    End If
    
    
    ' Initialize the return value to a default: the "empty" range (Nothing).
    Set FILTER_RANGE = Nothing
    
    
    ' Use the "empty" range if either filter is a blanket FALSE...
    If rowBlanket = "Exclude" Or columnBlanket = "Exclude" Then
        ' Set FILTER_RANGE = Nothing
    ' ...use the original range if both filters are blanket TRUEs...
    ElseIf rowBlanket = "Include" And columnBlanket = "Include" Then
        Set FILTER_RANGE = range
    ' ...and otherwise filter granularly.
    Else
        ' Set FILTER_RANGE = Nothing
        
        
        ' Cull the rows for filtration.
        If rowFilterType = "Array" Then
            Dim rowFilterIndex As Long
            rowFilterIndex = 0
            
            Dim rowFilter As range
            Set rowFilter = Nothing
            
            ' For efficiency, split the algorithms for when the filter orientation is a vector...
            If rowFilterArrayOrientation = "Vector" Then
                ' Iterate over every distinct row:
                For Each area In allRows.Areas
                    For Each singleRow In area.rows
                        ' Increment the index.
                        rowFilterIndex = rowFilterIndex + 1
                        
                        ' If the corresponding value in the filter vector is TRUE, then keep this row.
                        If include_rows(rowFilterIndex) = True Then
                            If rowFilter Is Nothing Then
                                Set rowFilter = singleRow
                            Else
                                Set rowFilter = Application.Union(rowFilter, singleRow)
                            End If
                        End If
                    Next
                Next
            ' ...or when it is a row in a rectangular array...
            ElseIf rowFilterArrayOrientation = "Row" Then
                ' Iterate over every distinct row:
                For Each area In allRows.Areas
                    For Each singleRow In area.rows
                        ' Increment the index.
                        rowFilterIndex = rowFilterIndex + 1
                        
                        ' If the corresponding value in the filter row is TRUE, then keep this row.
                        If include_rows(rowFilterIndex, 1) = True Then
                            If rowFilter Is Nothing Then
                                Set rowFilter = singleRow
                            Else
                                Set rowFilter = Application.Union(rowFilter, singleRow)
                            End If
                        End If
                    Next
                Next
            ' ...or when it is a column in a rectangular array.
            ElseIf rowFilterArrayOrientation = "Column" Then
                ' Iterate over every distinct row:
                For Each area In allRows.Areas
                    For Each singleRow In area.rows
                        ' Increment the index.
                        rowFilterIndex = rowFilterIndex + 1
                        
                        ' If the corresponding value in the filter column is TRUE, then keep this row.
                        If include_rows(1, rowFilterIndex) = True Then
                            If rowFilter Is Nothing Then
                                Set rowFilter = singleRow
                            Else
                                Set rowFilter = Application.Union(rowFilter, singleRow)
                            End If
                        End If
                    Next
                Next
            End If
            
            
            ' Apply (by row) the filter to the range.
            If Not rowFilter Is Nothing Then
                Set FILTER_RANGE = Application.Intersect(range, rowFilter)
            End If
        End If
        
        
        ' If any range is left, cull the columns for filtration.
        If Not FILTER_RANGE Is Nothing And columnFilterType = "Array" Then
            Dim columnFilterIndex As Long
            columnFilterIndex = 0
            
            Dim columnFilter As range
            Set columnFilter = Nothing
            
            ' For efficiency, split the algorithms for when the filter array is a vector...
            If columnFilterArrayOrientation = "Vector" Then
                ' Iterate over every distinct column:
                For Each area In allColumns.Areas
                    For Each singleColumn In area.Columns
                        ' Increment the index.
                        columnFilterIndex = columnFilterIndex + 1
                        
                        ' If the corresponding value in the filter vector is TRUE, then keep this column.
                        If include_columns(columnFilterIndex) = True Then
                            If columnFilter Is Nothing Then
                                Set columnFilter = singleColumn
                            Else
                                Set columnFilter = Application.Union(columnFilter, singleColumn)
                            End If
                        End If
                    Next
                Next
            ' ...or when it is a row in a rectangular array...
            ElseIf columnFilterArrayOrientation = "Row" Then
                ' Iterate over every distinct column:
                For Each area In allColumns.Areas
                    For Each singleColumn In area.Columns
                        ' Increment the index.
                        columnFilterIndex = columnFilterIndex + 1
                        
                        ' If the corresponding value in the filter row is TRUE, then keep this column.
                        If include_columns(columnFilterIndex, 1) = True Then
                            If columnFilter Is Nothing Then
                                Set columnFilter = singleColumn
                            Else
                                Set columnFilter = Application.Union(columnFilter, singleColumn)
                            End If
                        End If
                    Next
                Next
            ' ...or when it is a column in a rectangular array.
            ElseIf columnFilterArrayOrientation = "Column" Then
                ' Iterate over every distinct column:
                For Each area In allColumns.Areas
                    For Each singleColumn In area.Columns
                        ' Increment the index.
                        columnFilterIndex = columnFilterIndex + 1
                        
                        ' If the corresponding value in the filter column is TRUE, then keep this column.
                        If include_columns(1, columnFilterIndex) = True Then
                            If columnFilter Is Nothing Then
                                Set columnFilter = singleColumn
                            Else
                                Set columnFilter = Application.Union(columnFilter, singleColumn)
                            End If
                        End If
                    Next
                Next
            End If
            
            
            ' Apply (by column) the filter to the range.
            If Not columnFilter Is Nothing Then
                If rowFilterType = "Array" Then
                    Set FILTER_RANGE = Application.Intersect(FILTER_RANGE, columnFilter)
                Else
                    Set FILTER_RANGE = Application.Intersect(range, columnFilter)
                End If
            End If
        End If
    End If
    
    
    ' If the result set is empty, then set the result to the default value.
    If FILTER_RANGE Is Nothing Then
        Set FILTER_RANGE = if_empty
    End If
End Function

Helpers

Type Testers

' .
Public Function IS_BOOLEAN(var As Variant) As Boolean
    IS_BOOLEAN = (VarType(var) = vbBoolean)
End Function
' .
Public Function IS_RANGE(var As Variant) As Boolean
    IS_RANGE = (TypeOf var Is range)
End Function
' .
Public Function IS_ARRAY(var As Variant) As Boolean
    IS_ARRAY = IsArray(var)
End Function

Type Converters

I might eventually implement RANGE_TO_ARRAY_2() as inspired by this solution from Office Watch.

' .
Public Function RANGE_TO_ARRAY_1(range As Variant) As Variant
    RANGE_TO_ARRAY_1 = range.Value2
    '                        |----|
    '                        Use ".Value2" for better performance.
End Function
' .
Public Function RANGE_TO_ARRAY_2(range As range) As Variant
    ' ...
End Function

Array Functions

Credit to @aevanko for this solution on Stack Overflow, which inspired COUNT_ARRAY_DIMENSIONS():

' .
Public Function GET_ARRAY_LENGTH(arr As Variant, Optional dimension As Long = 1) As Long
    If IsEmpty(arr) Then
       GET_ARRAY_LENGTH = 0
    Else
       GET_ARRAY_LENGTH = UBound(arr, dimension) - LBound(arr, dimension) + 1
    End If
End Function
' .
Private Function COUNT_ARRAY_DIMENSIONS(ByVal arr As Variant) As Long
    ' Increment until we run out of dimensions...
    Dim dimnum As Long
    On Error GoTo FinalDimension
    
    For dimnum = 1 To 60000
        ErrorCheck = LBound(arr, dimnum)
    Next

' ...and include everything up to the last dimension.
FinalDimension:
    COUNT_ARRAY_DIMENSIONS = dimnum - 1
End Function

Range Functions

' .
Public Function COUNT_ALL_ROWS(range As range, Optional unique As Boolean = True) As Long
    Dim consolidatedRows As range
    Set consolidatedRows = Nothing
    
    ' Consolidate all relevant rows as desired.
    If unique Then
        Set consolidatedRows = GET_ALL_ROWS(range)
    Else
        Set consolidatedRows = range
    End If
    
    ' Count the rows.
    COUNT_ALL_ROWS = 0
    For Each area In consolidatedRows.Areas
        COUNT_ALL_ROWS = COUNT_ALL_ROWS + area.rows.CountLarge
    Next
End Function
' .
Public Function COUNT_ALL_COLUMNS(range As range, Optional unique As Boolean = True) As Long
    Dim consolidatedColumns As range
    Set consolidatedColumns = Nothing
    
    ' Consolidate all relevant columns as desired.
    If unique Then
        Set consolidatedColumns = GET_ALL_COLUMNS(range)
    Else
        Set consolidatedColumns = range
    End If
    
    ' Count the rows.
    COUNT_ALL_COLUMNS = 0
    For Each area In consolidatedColumns.Areas
        COUNT_ALL_COLUMNS = COUNT_ALL_COLUMNS + area.Columns.CountLarge
    Next
End Function

' .
Private Function GET_ALL_ROWS(range As range) As range
    Set GET_ALL_ROWS = Nothing
    
    For Each area In range.Areas
        If GET_ALL_ROWS Is Nothing Then
            Set GET_ALL_ROWS = area.EntireRow
        Else
            Set GET_ALL_ROWS = Application.Union(GET_ALL_ROWS, area.EntireRow)
        End If
    Next
End Function
' .
Private Function GET_ALL_COLUMNS(range As range) As range
    Set GET_ALL_COLUMNS = Nothing
    
    For Each area In range.Areas
        If GET_ALL_COLUMNS Is Nothing Then
            Set GET_ALL_COLUMNS = area.EntireColumn
        Else
            Set GET_ALL_COLUMNS = Application.Union(GET_ALL_COLUMNS, area.EntireColumn)
        End If
    Next
End Function
\$\endgroup\$
2
  • 1
    \$\begingroup\$ Out of interest, have you actually timed this to measure performance? \$\endgroup\$
    – Greedo
    Jun 10 at 8:16
  • \$\begingroup\$ @Greedo No, I'm afraid I haven't had the chance to test it on anything larger than a small range. I'm actually not sure how I'd go about benchmarking something like this: I've only ever benchmarked performance in R, and I have no idea how to do so in VBA or Excel. I simply assumed the worst case scenario — irregular ranges of absurd size — and constructed my flow to minimize memory usage and avoid redundancy in iterative code. \$\endgroup\$
    – Greg
    Jun 10 at 12:21

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.