Excel VBA Get Applied Filter Criteria

In many cases we apply multiple filters to a table, or a sheet range and we need to document what filters did we use to get the displayed values.

This procedure when run on the active sheet, will create a new sheet named "Filters" showing each field header and the type of filter that was applied to it and what criteria was used. 

Leave any comment and we will do our best to answer them or update the code accordingly.

'Always start with option explicit

Option Explicit

'MAIN PRCEDURE

' ----------------------------------------------------------------
' Procedure Name: GetFilters
' Purpose: Write all the applied filters on the active sheet to a new Excel sheet
' Procedure Kind: Procedure
'
' Author:  PARACON CONSULTANTS CORP.
' Website: https://paracons.ca
' eMail:   info@paracons.ca
' Date:  10/3/2022
' ----------------------------------------------------------------

Sub GetFilters()

Dim sh As Worksheet 'Active sheet

Dim shFilters As Worksheet 'sheet where the filter criteria will be written

Dim oFilt As Filter

Dim vOps As Variant  'lookup array to hold the different filter names according to their operation number

Dim oData As Variant 'this will get the object that has the data. It can be the active worksheet itself or a table (ListObject) in the active sheet

Dim vFilters As Variant 'an array to hold the filter criteria.

Dim vDates As Variant 'an array to to hold the dates filtered values

Dim c As Long

Dim r As Long

Dim i As Long

Dim LastRow As Long 'last row of the data

Dim LastCol As Long 'last column of the data

Set sh = ThisWorkbook.ActiveSheet

'if there is a table in the sheet then use it as the data source

If sh.ListObjects.Count > 0 Then

    Set oData = sh.ListObjects(1)

    'if there are no filters created then exit

    If oData.ShowAutoFilter = False Then Exit Sub

'if there is no table then take the active sheet as the data source

Else

    Set oData = sh

    'if there are no filters created then exit

    If oData.AutoFilterMode = False Then Exit Sub

End If

'if the created filters were not used then exit

If sh.FilterMode = False Then Exit Sub

'if the macro was previously run then use the Filters sheet that was created. This is where we will write the filter criteria.

If SheetExists("Filters") Then

    Set shFilters = ThisWorkbook.Worksheets("Filters")

    shFilters.UsedRange.Delete

'if the Filters sheet was not found then create it

Else

    Set shFilters = ThisWorkbook.Worksheets.Add(, sh)

    shFilters.Name = "Filters"

End If

'populate vOps array so that each Operator name is in its value position.

vOps = Array("", "xlAnd", "xlOr", "xlTop10Items", "xlBottom10Items", "xlTop10Percent", "xlBottom10Percent", "xlFilterValues", "xlFilterCellColor", "xlFilterFontColor", "xlFilterIcon", "xlFilterDynamic", "xlFilterNoFill", "xlFilterAutomaticFontColor", "xlFilterNoIcon")

'redimensioning the filters array so it fits the maximum possible criteria

LastRow = sh.UsedRange.Rows.Count

LastCol = sh.UsedRange.Columns.Count

ReDim vFilters(1 To LastRow, 1 To LastCol)

'writing the data column headrs to the filters array

For c = 1 To UBound(vFilters, 2)

    vFilters(1, c) = sh.Cells(1, c).Value

Next c

 

'now we will start getting the criteria into the vFilters array

With oData.AutoFilter 

    c = 0

    'looping on each column

    For Each oFilt In .Filters

        With oFilt

            'shifting to the current column position

            c = c + 1

            'starting from row number 2 for each column

            r = 2

            'if the filter of the current column is used

            If .On = True Then

                'writing the operator's name inthe second row (just below the column header)

                vFilters(r, c) = vOps(.Operator) 'we are getting the operator name from its position in the vOps array.

                'if the field is not a date field then the filter count will be more than 0.

                If .Count > 0 Then

                    'if criteria 1 is array then the user selected specific values and there is no criteria 2

                    If IsArray(.Criteria1) = True Then

                        'writing the filtered values to the vFIlters array

                        For i = LBound(.Criteria1) To UBound(.Criteria1)

                            r = r + 1

                            vFilters(r, c) = .Criteria1(i)

                        Next i

                    'if criteria1 is not an array then just get the value of criteria1 and criteria 2

                    Else

                        r = r + 1

                        'the criteria property name depends on the operator type.

                        'if the filter is by cell color then the value is assigned to the Color property

                        If .Operator = xlFilterCellColor Or .Operator = xlFilterNoFill Then

                            vFilters(r, c) = .Criteria1.Color

                        'if the filter is by Icon then the value is assigned to the Index property

                        ElseIf .Operator = xlFilterIcon Then

                            vFilters(r, c) = .Criteria1.Index

                        'if the filter is by cells that has no Icon then there is no value

                        ElseIf .Operator = xlFilterNoIcon Then

                        'if the Above or Below Average filters is used then the operatot is the same (xlFilterDynamic) and the value is in the Criteria1 property

                        ElseIf .Operator = xlFilterDynamic Then

                            'if the vlaue is 33 then Above Average is used

                            If .Criteria1 = 33 Then

                                vFilters(r, c) = "Above Average"

                            'if the value is 34 then Below Average is used

                            ElseIf .Criteria1 = 34 Then

                                vFilters(r, c) = "Below Average"

                            End If

                        'if the filter is none of the above then the value is in the Criteria1 property

                        Else

                            vFilters(r, c) = .Criteria1

                        End If

                        'if there is a second criteria used

                        If .Count > 1 Then

                            r = r + 1

                            vFilters(r, c) = .Criteria2

                        End If

                    End If

                'if it is a date field then we get the filtered criteria from the values displayed on the sheet itself

                Else

                    'getting the filtered values fromt the helper function GetVisibleValues by pasing to it the current column range

                    vDates = GetVisibleValues(sh.Range(Cells(2, c).Address & ":" & Cells(LastRow, c).Address))

                    'if there is more than 1 date then an array will be returned

                    If IsArray(vDates) Then

                        'writing the returned array values to the vFilters array

                        For i = LBound(vDates) To UBound(vDates)

                            r = r + 1

                            vFilters(r, c) = vDates(i, 1)

                        Next i

                    'if only one date was selected then the function will return a date value

                    Else

                        r = r + 1

                        vFilters(r, c) = vDates

                    End If

                End If

 

            End If

        End With

    Next oFilt

End With

'write the filters to the Filters sheet

shFilters.Cells.NumberFormat = "@"

shFilters.Range("A1:" & Cells(LastRow, LastCol).Address) = vFilters

shFilters.Activate

End Sub

 

 

'HELPER FUNCTION TO GET THE VISIBLE VALUES IN A RANGE

' ----------------------------------------------------------------
' Procedure Name: GetVisibleValues
' Purpose: Returns a distinct list of visible values in a range. If there is only one value then it will be returned in the variable.
' Procedure Kind: Function
' Parameter oRange (Range): the column range to get the visible values from
' Return Type: Variant
'
' Author:  PARACON CONSULTANTS CORP.
' Website: https://paracons.ca
' eMail:   info@paracons.ca
' Date:  10/3/2022
' ----------------------------------------------------------------

Function GetVisibleValues(oRange As Range) As Variant

    Dim r As Long

    Dim sh As Worksheet

    'we will use the filters sheet as a temporaty sheet to write the filtered range values to it

    Set sh = ThisWorkbook.Worksheets("Filters")

    oRange.SpecialCells(xlCellTypeVisible).Copy sh.Range("A1")

    'removing the duplicates and sorting

    With sh

        .Range("A:A").RemoveDuplicates 1, xlNo

        r = .Cells(.Rows.Count, 1).End(xlUp).Row

        .Sort.SortFields.Clear

        .Sort.SortFields.Add2 Key:=Range("A1:A" & r), _

            SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal

        With .Sort

            .SetRange Range("A1:A" & r)

            .Header = xlNo

            .MatchCase = False

            .Orientation = xlTopToBottom

            .SortMethod = xlPinYin

            .Apply

        End With

        'returning the deduped valus

        GetVisibleValues = .Range("A1:A" & r).Value

        'deleting the values from the Filter sheet.

        .Range("A1:A" & r).Delete

    End With

End Function


Leave a comment

This site is protected by reCAPTCHA and the Google Privacy Policy and Terms of Service apply.


You may also like

View all
Excel VBA Get Applied Filter Criteria
VBA Code Spelled numbers to number
Excel: How to Case Sensitive Vlookup formula
How to unprotect Excel sheet without password
Installing Primavera on SQL Server