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