How do I get Filter Criteria in Excel 2016 using VBA?

Question

I am working on an Excel 2016 VBA Macro that applies a filter to the headings column. Afterwards, the user applies the filter criteria. I would like to be able to in VBA retrieve the filter criteria that the user applied and save it to a string array. Is there a way to access the filter criteria?

Answer 1

02/02/2024 : I have a code working with Office 365. I take days to find a solution working on multiple value filters. Youhoo! It seems that I don t have a bug when the cursor is out from the data, like others has get. Please find here my code :

Sub Bouton1_Cliquer() ' Get Filters : Right button
  Dim NameWorksheetDCT As String
  Dim OutTblRef As String
  NameWorksheetDCT = ActiveSheet.Range("W3").Text
  OutTblRef = "AA1"
  ActiveSheet.Range(ExtendRangeCell(OutTblRef, 2, 11)).ClearContents
  Call GetFiltersFromTbl(Worksheets(NameWorksheetDCT).Range(ActiveSheet.Range("Y3").Text), ActiveSheet.Range(OutTblRef))
End Sub
Sub Bouton1S_Cliquer() ' Set Filters : Right button
  Dim NameWorksheetDCT As String
  Dim OutTblRef As String
  NameWorksheetDCT = ActiveSheet.Range("W3").Text
  OutTblRef = "AA1"
  If MsgBox("Etes vous sure de reseter et modifier les filtres du tableau ?", vbYesNo) = vbNo Then Exit Sub:
  Call SetFiltersFromTbl(Worksheets(NameWorksheetDCT).Range(ActiveSheet.Range("Y3").Text), ActiveSheet.Range(OutTblRef))
End Sub
Sub GetFiltersFromTbl(InTbl As Range, RecFilt As Range)
  Dim Str As String
  Dim InputRange As Range
  Dim cell As Range
  Dim a As Integer
  Dim i As Integer: Dim ii As Integer
  Dim nbr_col As Integer

  i = 0: ii = 0
  Do While InTbl.Offset(0, i).Text <> "End _TBL"
     Str = GetFilterCriteria(InTbl.Offset(0, i))
     a = i + 1
     If Str <> "" Then
        Title = InTbl.Offset(0, i).Text
        RecFilt.Offset(0, ii).Value = Title
        RecFilt.Offset(1, ii).Value = ColumnNbrToLetter(a)
        RecFilt.Offset(2, ii).Value = "•" & Str
        ii = ii + 1
     End If
     i = i + 1
  Loop
End Sub


Sub SetFiltersFromTbl(InTbl As Range, Filt_Param As Range)
  Dim FilterI As String
  Dim i As Integer
  Dim iOr As Integer: Dim iAnd As Integer
  'InTbl.Worksheet.ActiveCell.Offset(InTbl.Row + 1, ActiveCell.Column).Activate
  'todo Move the ActiveCell to be in the data Filtered : BUG MICROSOFT TO SOLVE. I don t have it myself
  If InTbl.Worksheet.AutoFilterMode Then
    InTbl.Worksheet.AutoFilter.ShowAllData
  End If
  i = 0
  FilterI = Filt_Param.Offset(2, i).Value
  Do While Len(FilterI) > 2
     Idx_Filt = ColumnLetterToNbr(Filt_Param.Offset(1, i).Value)
     iOr = InStr(1, FilterI, "||"): iAnd = InStr(1, FilterI, "&&")
     If iAnd > 0 Then ' Case Criteria 2 with OR
         InTbl.AutoFilter Field:=Idx_Filt, Criteria1:=Mid(FilterI, 2, iAnd - 2), Operator:=xlAnd, Criteria2:=Mid(FilterI, iAnd + 2, Len(FilterI) - iAnd - 2)
     ElseIf iOr > 0 Then ' Case Criteria 2 with AND
         InTbl.AutoFilter Field:=Idx_Filt, Criteria1:=Mid(FilterI, 2, iOr - 2), Operator:=xlOr, Criteria2:=Mid(FilterI, iOr + 2, Len(FilterI) - iOr - 2)
     ElseIf CountChrInStr(FilterI, "•") = 2 Then 'Single value filter
         InTbl.AutoFilter Field:=Idx_Filt, Criteria1:=Mid(FilterI, 2, Len(FilterI) - 2), Operator:=xlFilterValues
     Else 'Array of values filter
         InTbl.AutoFilter Field:=Idx_Filt, Criteria1:=(Split(Mid(FilterI, 2, Len(FilterI) - 2), "•")), Operator:=xlFilterValues
     End If
     i = i + 1
     FilterI = Filt_Param.Offset(2, i).Text
  Loop
End Sub

Function ExtrFilterParam(StrAll As String, Id_Param As Integer)
  ExtrFilterParam = ""
  For i = 0 To Id_Param
    Idx = InStr(Idx, StrAll, "•")
    If Idx = 0 Then Exit Function:
  Loop
  ExtrFilterParam = Mid(StrAll, Idx + 1, InStr(Idx, StrAll, "•") - Idx - 1)
End Function


Function GetFilterCriteria(Rng As Range) As String
    Application.Volatile
    Dim Filter As String
    Filter = ""
    On Error GoTo Finish
      'Rng.Parent.AutoFilter.Filter.count
    With Rng.Parent.AutoFilter
        If Intersect(Rng, .Range) Is Nothing Then GoTo Finish
        With .Filters(Rng.Column - .Range.Column + 1)
            If Not .On Then GoTo Finish
              On Error GoTo Finish
              Select Case .Operator
                Case xlAnd
                    Filter = .Criteria1 & "&&" & .Criteria2 & "•"
                Case xlOr
                    Filter = .Criteria1 & "||" & .Criteria2 & "•"
                Case Else
                    On Error GoTo Nxt
                    Filter = .Criteria1 & "•"
Nxt:
                    On Error GoTo Nxt2 ' Multiple Value treatment
                    For Each Criteria In .Criteria1
                        Filter = Filter & Criteria & "•"
                    Next Criteria
Nxt2:
            End Select
        End With
    End With
Finish:
GetFilterCriteria = Filter
End Function


' Plus here the custom functions  that I have self made (with ChatGPT help) :
Function ColumnNbrToLetter(columnNumber As Integer) As String
    Dim dividend As Integer
    Dim columnLetter As String
    Dim modulo As Integer

    If columnNumber < 1 Then
        ColumnNumberToLetter = "Invalid Column"
        Exit Function
    End If

    columnLetter = ""
    dividend = columnNumber

    Do
        modulo = (dividend - 1) Mod 26
        columnLetter = Chr(65 + modulo) & columnLetter
        dividend = (dividend - modulo) \ 26
    Loop While dividend > 0

    ColumnNbrToLetter = columnLetter
End Function

Function ColumnLetterToNbr(Letter As String) As Long
    Dim colNumber As Long
    Dim i As Integer

    colNumber = 0
    For i = Len(Letter) To 1 Step -1
        colNumber = colNumber + (Asc(UCase(Mid(Letter, i, 1))) - 64) * (26 ^ (Len(Letter) - i))
    Next i

    ColumnLetterToNbr = colNumber
End Function

Function CountChrInStr(StrIn As String, charToFind As String) As Integer
    Dim Count As Integer
    Dim position As Long
    Count = 0
    position = InStr(1, StrIn, charToFind)
    Do While position > 0
        Count = Count + 1
        position = InStr(position + 1, StrIn, charToFind)
    Loop
    CountChrInStr = Count
End Function

Answer 2

I'd like to add a bit to the discussion. I found this (and other excellent sources of help) when investigating how to "return" the filter status. In my case, I want to DISPLAY the filter status in a cell on a worksheet.

As I said, this question and many others like it were quite useful. From that, I was able to build the function shown in the code below.

I pass it the name of the Table for which I want the filter status... thus it's passed in as a RANGE and it then needs to look in the PARENT (sheet) for information. This is because there may be several Tables on the SHEET from which it comes, so I can't just use the SHEET itself to get Autofilter information.

This works well, except for one thing: if the active cell on the worksheet is NOT within the table in question, the function will see the number of filters as zero (WholeTable.Parent.Autofilter.Filters.Count in the sample below). I do not understand why this is, nor how to prevent it. If the active cell IS within the table range, it works perfectly.

Any hints would be appreciated!

Code:

---

Public Function AutoFilterCriteria(ByVal WholeTable As Range) As String

On Error Resume Next

If WholeTable.Parent.AutoFilter Is Nothing Then                     ' if no filter is applied
    AutoFilterCriteria = "None"
    On Error GoTo 0
    Exit Function
End If

Dim LongStr As String, FirstOne As Boolean
LongStr = ""
FirstOne = False

Dim iFilt As Integer
For iFilt = 1 To WholeTable.Parent.AutoFilter.Filters.Count         ' loop through each column of the table
    Dim ThisFilt As Filter
    Set ThisFilt = WholeTable.Parent.AutoFilter.Filters(iFilt)      ' look at each filter
    On Error Resume Next
    With ThisFilt
        If .On Then
            If FirstOne Then LongStr = LongStr & " AND "            ' Get column title
            LongStr = LongStr & "[" & WholeTable.Parent.Cells(WholeTable.Row - 1, WholeTable.Column + iFilt - 1).Value & ":"
            On Error GoTo Handle
            If .Operator = xlFilterValues Then                      ' dont really care to enumerate multiples, just show "multiple"
                LongStr = LongStr & "<Multiple>]"
            ElseIf .Operator = 0 Then
                LongStr = LongStr & .Criteria1 & "]"
            ElseIf .Operator = xlAnd Then
                LongStr = LongStr & .Criteria1 & " AND " & .Criteria2 & "]"
            ElseIf .Operator = xlOr Then
                LongStr = LongStr & .Criteria1 & " OR " & .Criteria2 & "]"
            End If
            On Error GoTo 0
            FirstOne = True
        End If
    End With
Next

AutoFilterCriteria = LongStr
On Error GoTo 0
Exit Function

Handle:
AutoFilterCriteria = "! Error !"
On Error GoTo 0

End Function

Answer 3

the code would to be like this. The code of field is cells(1, f).

Dim sht As Worksheet
Set sht = ActiveSheet
With sht.AutoFilter
    With .Filters
        ReDim filtarr(1 To .Count, 1 To 4) ' change array
        For f = 1 To .Count
            With .Item(f)
                If .On Then
                    filtarr(f, 1) = .Criteria1
                    filtarr(f, 4) = Cells(1, f) 'field
                    Debug.Print .Criteria1, Cells(1, f)
                    If .Operator Then
                        filtarr(f, 2) = .Operator
                        filtarr(f, 3) = .Criteria2

                        Debug.Print .Operator & ", " & .Criteria2
                    End If
                End If
            End With
        Next f
    End With
End With

Answer 4

I checked this question and pretty much copied the first part of the code, the only thing is you don't get the field that it is applied to which can be problematic.

Dim sht As Worksheet
Set sht = ActiveSheet
With sht.AutoFilter
    With .Filters
        ReDim filtarr(1 To .Count, 1 To 3)
        For f = 1 To .Count
            With .Item(f)
                If .On Then
                    filtarr(f, 1) = .Criteria1
                    Debug.Print .Criteria1
                    If .Operator Then
                        filtarr(f, 2) = .Operator
                        filtarr(f, 3) = .Criteria2
                        Debug.Print .Operator & ", " & .Criteria2
                    End If
                End If
            End With
        Next f
    End With
End With