Sync AutoFilter between 2 Tables on same Worksheet

[kleinmat]

Hi,

I have a workbook with a Sheet that contains 3 tables.
The first 2 columns of each table hold the exact same information.

I have turned those columns into proper Excel Tables, calling them Table1, Table2, Table3. I have also added an Auto-Filter to all three.

Now I am trying to find a way to sync the Auto Filter settings between all 3 tables automatically.

Take a look at the attached screenshots that shows a much simplified version of what I want to achieve. If I filter for the surname "Adams" in the first table, it just applies that filter to the first table.
But what I want is that it filters all 3 tables.

How can that be done?

Thank you so much for your help!
Matt

 

[John_w]

Try the code below, which reads the AutoFilter settings for Table1 and applies them to Table2 and Table3, all on "Sheet1". But note the problem I describe at the bottom of this post.

One difficulty is that there isn't an Excel event which is triggered when you change an AutoFilter. However, there is a workaround described at Excel VBA Filter Change event handler. This involves adding a dummy worksheet (which could be hidden) and putting a formula in one of its cells which references cells in Table1 or adjacent to Table1 on Sheet1. Choose cells which make the formula recalculate when you change the AutoFilter so that the dummy worksheet's Worksheet_Calculate event is run and calls the Sync_AutoFilter_Tables routine to synchronise Table2 and Table3 with Table1.

Code in the sheet module of the dummy worksheet:

Option Explicit

Private Sub Worksheet_Calculate()
    'Dummy worksheet cell A1 contains the formula =SUBTOTAL(9,Sheet1!F1:F23).  This formula references cells adjacent to Table1 on Sheet1
    If MsgBox(Me.Name & " Worksheet_Calculate", vbOKCancel) = vbCancel Then
        Stop
    End If
    Sync_AutoFilter_Tables
End Sub

The If MsgBox.... code above is for debugging/diagnostic purposes and not needed for the synchronisation functionality.

Code in a standard module:

Option Explicit


Public Sub Sync_AutoFilter_Tables()

    Dim table1 As ListObject, table2 As ListObject, table3 As ListObject
    Dim table1AutoFilters As Variant
 
    With ThisWorkbook.Worksheets("Sheet1")
        Set table1 = .ListObjects("Table1")
        Set table2 = .ListObjects("Table2")
        Set table3 = .ListObjects("Table3")
    End With
 
    table1AutoFilters = Get_Table_AutoFilters(table1)
    
    Application.EnableEvents = False
   
    Apply_AutoFilters_To_Table table2, table1AutoFilters
    Apply_AutoFilters_To_Table table3, table1AutoFilters
 
    Application.EnableEvents = True
 
    If MsgBox("Synced " & Now, vbOKCancel) = vbCancel Then
        Stop
    End If

End Sub


'Returns an array of the autofilter settings for the specified table.
'Based on https://stackoverflow.com/a/44937214, but for a table, instead of a worksheet

Public Function Get_Table_AutoFilters(table As ListObject) As Variant

    Dim f As Long
    Dim filt As Filter
    Dim s As String
 
    If Not table.AutoFilter Is Nothing Then
        With table.AutoFilter
            With .Filters
                s = ""
                ReDim filtersarray(1 To .Count, 1 To 3) As Variant
                For f = 1 To .Count
                    Set filt = .Item(f)
                    With filt
                        If .On Then
                            s = s & "Worksheets(" & Q(table.Parent.Name) & ").ListObjects(" & Q(table.Name) & ").Range.AutoFilter Field:=" & f
                            filtersarray(f, 1) = .Criteria1
                            If IsArray(.Criteria1) Then
                                s = s & ", Criteria1:=" & Cvt_Array_String(.Criteria1)
                            Else
                                s = s & ", Criteria1:=" & Q(.Criteria1)
                            End If
                            If .Operator Then
                                filtersarray(f, 2) = .Operator
                                s = s & ", Operator:=" & Cvt_Filter_Operator(CVar(filtersarray(f, 2)))
                                On Error Resume Next
                                filtersarray(f, 3) = .Criteria2
                                On Error GoTo 0
                                If filtersarray(f, 3) <> Empty Then s = s & ", Criteria2:=" & Q(.Criteria2)
                            End If
                            s = s & vbCrLf
                        End If
                    End With
                Next
            End With
        End With
        If s <> "" Then
            Debug.Print s
            MsgBox table.Name & " - Worksheet " & Q(table.Parent.Name) & " Range " & table.AutoFilter.Range.Address & vbCrLf & vbCrLf & _
                   Left(s, Len(s) - 1), Title:="AutoFilter statement(s)"
        Else
            Debug.Print "No filters applied to table: " & table.Name & " - Worksheet " & Q(table.Parent.Name) & " Range " & table.AutoFilter.Range.Address
            MsgBox table.Name & " - Worksheet " & Q(table.Parent.Name) & " Range " & table.AutoFilter.Range.Address & vbCrLf & vbCrLf & _
                   "No filters applied", Title:="AutoFilter statement(s)"
        End If
        Get_Table_AutoFilters = filtersarray
    End If
 
End Function


Public Sub Apply_AutoFilters_To_Table(table As ListObject, ByVal savedAutoFilters As Variant)

    Dim f As Long
    Dim Criteria1Arg As Variant, Criteria2Arg As Variant
    Dim s As String
 
    s = ""
    For f = 1 To UBound(savedAutoFilters)
        s = s & "Worksheets(" & Q(table.Parent.Name) & ").ListObjects(" & Q(table.Name) & ").Range.AutoFilter Field:=" & f
        If Not IsEmpty(savedAutoFilters(f, 1)) Then       'Criteria1
            If IsEmpty(savedAutoFilters(f, 2)) Then       'Operator
                'Operator is empty, so only Criteria1 applies
                If IsArray(savedAutoFilters(f, 1)) Then
                    s = s & ", Criteria1:=" & Cvt_Array_String(savedAutoFilters(f, 1))
                Else
                    s = s & ", Criteria1:=" & Q(CStr(savedAutoFilters(f, 1)))
                End If
                table.DataBodyRange.AutoFilter Field:=f, Criteria1:=savedAutoFilters(f, 1)
            Else
                'Operator provided
                If IsEmpty(savedAutoFilters(f, 3)) Then   'Criteria2
                    'Criteria2 not provided, so only Criteria1 applies
                    If IsArray(savedAutoFilters(f, 1)) Then
                        s = s & ", Criteria1:=" & Cvt_Array_String(savedAutoFilters(f, 1))
                    Else
                        s = s & ", Criteria1:=" & Q(CStr(savedAutoFilters(f, 1)))
                    End If
                    s = s & ", Operator:=" & Cvt_Filter_Operator(CVar(savedAutoFilters(f, 2)))
                    table.DataBodyRange.AutoFilter Field:=f, Criteria1:=savedAutoFilters(f, 1), Operator:=savedAutoFilters(f, 2)
                Else
                    'Criteria2 provided, so both Criteria1 and Criteria2 apply
                    If IsArray(savedAutoFilters(f, 1)) Then
                        s = s & ", Criteria1:=" & Cvt_Array_String(savedAutoFilters(f, 1))
                    Else
                        s = s & ", Criteria1:=" & Q(CStr(savedAutoFilters(f, 1)))
                    End If
                    s = s & ", Operator:=" & Cvt_Filter_Operator(CVar(savedAutoFilters(f, 2))) & ", Criteria2:=" & Q(CStr(savedAutoFilters(f, 3)))
                    table.DataBodyRange.AutoFilter Field:=f, Criteria1:=savedAutoFilters(f, 1), Operator:=savedAutoFilters(f, 2), Criteria2:=savedAutoFilters(f, 3)
                End If
            End If
        Else
            table.DataBodyRange.AutoFilter Field:=f
        End If
        s = s & vbCrLf
    Next
 
    Debug.Print s
 
End Sub


Private Function Cvt_Array_String(arr As Variant) As String

    Dim i As Long
   
    Cvt_Array_String = "Array("
    For i = LBound(arr) To UBound(arr)
        Cvt_Array_String = Cvt_Array_String & Q(Replace(arr(i), "=", "")) & ", "
    Next
    Cvt_Array_String = Left(Cvt_Array_String, Len(Cvt_Array_String) - 2) & ")"
   
End Function


Private Function Cvt_Filter_Operator(op As XlAutoFilterOperator) As String
 
    Select Case op
        Case XlAutoFilterOperator.xlAnd: Cvt_Filter_Operator = "xlAnd"
        Case XlAutoFilterOperator.xlBottom10Items: Cvt_Filter_Operator = "xlBottom10Items"
        Case XlAutoFilterOperator.xlBottom10Percent: Cvt_Filter_Operator = "xlBottom10Percent"
        Case XlAutoFilterOperator.xlFilterAutomaticFontColor: Cvt_Filter_Operator = "xlFilterAutomaticFontColor"
        Case XlAutoFilterOperator.xlFilterCellColor: Cvt_Filter_Operator = "xlFilterCellColor"
        Case XlAutoFilterOperator.xlFilterDynamic: Cvt_Filter_Operator = "xlFilterDynamic"
        Case XlAutoFilterOperator.xlFilterFontColor: Cvt_Filter_Operator = "xlFilterFontColor"
        Case XlAutoFilterOperator.xlFilterIcon: Cvt_Filter_Operator = "xlFilterIcon"
        Case XlAutoFilterOperator.xlFilterNoFill: Cvt_Filter_Operator = "xlFilterNoFill"
        Case XlAutoFilterOperator.xlFilterNoIcon: Cvt_Filter_Operator = "xlFilterNoIcon"
        Case XlAutoFilterOperator.xlFilterValues: Cvt_Filter_Operator = "xlFilterValues"
        Case XlAutoFilterOperator.xlOr: Cvt_Filter_Operator = "xlOr"
        Case XlAutoFilterOperator.xlTop10Items: Cvt_Filter_Operator = "xlTop10Items"
        Case XlAutoFilterOperator.xlTop10Percent: Cvt_Filter_Operator = "xlTop10Percent"
        Case Else: Cvt_Filter_Operator = "**UNKNOWN**"
    End Select
 
End Function


Private Function Q(ByVal text As String) As String
    Q = Chr(34) & text & Chr(34)
End Function

Again, the code above contains diagnostic/debugging code (the MsgBox and Debug.Print statements and the 's' string variable) and isn't needed and can therefore be commented out.

Problem - in my tests Table2 and Table3 don't sync automatically when I change the AutoFilter for Table1. Worksheet_Calculate is correctly fired and Sync_AutoFilter_Tables is called, however the Table2 and Table3 AutoFilters don't change and I don't know why. Their AutoFilters change perfectly if you run the Sync_AutoFilter_Tables routine (macro) manually, e.g. from the Developer tab or VBA editor or with a form command button assigned to that macro.