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 PROCEDURE
' ----------------------------------------------------------------
' 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://paracon.ca
' eMail: info@paracon.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