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.

 

[John_w]

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.

Problem fixed by calling Sync_AutoFilter_Tables using Application.OnTime instead of directly.

Apply the code in post #2 and make the following changes.

1. Replace the Worksheet_Calculate code in the sheet module of the dummy worksheet with:

Private Sub Worksheet_Calculate()
    'Dummy worksheet cell A1 contains the formula =SUBTOTAL(9,Table1[#All])
    Application.OnTime Now, "Sync_AutoFilter_Tables", , True
End Sub

Note - my formula in A1 on the dummy worksheet references all the cells, including headers, of Table1 on Sheet1: =SUBTOTAL(9,Table1[#All])

2. Replace the Apply_AutoFilters_To_Table routine - to handle the case of no autofilters being applied - with:

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 = ""
    If Not IsEmpty(savedAutoFilters) Then
        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
    Else
        'No filters
        table.DataBodyRange.AutoFilter
    End If
    Debug.Print s
   
End Sub

The above solution should work for any and all filtered columns in Table1.

 

[kleinmat]

Thank you!

I have now done the following:
1. Activated Macros in the Excel Trust Center, and saved the Excel as macro-enabled worksheet

2. Created a Tab "dummy" and added a SUBTOTAL formula into cell A1

3. In the code for that Tab, I added that Calculate function

4. In the code for the Worksheet as a whole, I added the other code you provided

5. The only change I made is to edit the name of the Tab on which the Tables reside

6. Then I saved it all, closed the work sheet, and re-opened it

Then I added some dummy values to that "Table1" and played with the AutoFilter.

The formula in dummy.A1 did work as expected.

BUT I get an error message when Excel tries to execute that VBA code in the dummy Tab.

Any idea?
Thank you!
Matt

 

[John_w]

2. Created a Tab "dummy" and added a SUBTOTAL formula into cell A1

3. In the code for that Tab, I added that Calculate function

You've put the Worksheet_Calculate code in the correct module (the "dummy" sheet's module).

4. In the code for the Worksheet as a whole, I added the other code you provided

5. The only change I made is to edit the name of the Tab on which the Tables reside

However, you've incorrectly put the rest of the code in the ThisWorkbook module, which accounts for the error you're seeing.

The rest of the code should go in a new standard module. In the VBA editor, click Insert -> Module:

And paste the code in the new module (Module1):

 

[kleinmat]

THANK YOU!

Yes, that did it!

Once I had remove the MsgBox-Statements, it worked as expected. I only noticed two things:
1. The Sync takes approx. 10 seconds. Is that normal?
2. The Sync does something weird with the formatting of the tables when filters are applied. See the attached screenshot: that line between the names and the missing right border on lines 3+4 is not correct.

Any ideas?

 

[John_w]

1. The Sync takes approx. 10 seconds. Is that normal?

Hard to say what normal should be with your setup. In my tests the sync is virtually immediate < 1 second. As I said, you could delete the lines involving the 's' string variable, since that's just for debugging/informational purposes, but the speed improvement would be negligible.

2. The Sync does something weird with the formatting of the tables when filters are applied. See the attached screenshot: that line between the names and the missing right border on lines 3+4 is not correct.

Again, I don't why this happens. I tried to reproduce the issue by putting an outside border around the whole table, but the formatting stays correct.