Get AutoFilter sort criteria and apply on second sheet

Question

I\'m trying to see if I can programatically trap an AutoFilter sort event, get the sort criteria and then apply that same sort criteria to an AutoFilter in a second workshee

Answer 1

Found this code:

Sub ShowAutoFilterCriteria()
' John Green et. al: Excel 2000 VBA Programmer?s Reference, S. 379f
' 09.01.2005
Dim oAF As AutoFilter
Dim oFlt As Filter
Dim sField As String
Dim sCrit1 As String
Dim sCrit2 As String
Dim sMsg As String
Dim i As Integer

' Check if the sheet is filtered at all
If ActiveSheet.AutoFilterMode = False Then
MsgBox "The sheet does not have an Autofilter"
Exit Sub
End If

' Get the sheet?s Autofilter object
Set oAF = ActiveSheet.AutoFilter

' Loop through the Filters of the Autofilter
For i = 1 To oAF.Filters.Count

' Get the field name form the first row
' of the Autofilter range
sField = oAF.Range.Cells(1, i).Value

' Get the Filter object
Set oFlt = oAF.Filters(i)

' If it is on...
If oFlt.On Then

' Get the standard filter criteria
sMsg = sMsg & vbCrLf & sField & oFlt.Criteria1

' If it?s a special filter, show it
Select Case oFlt.Operator
Case xlAnd
sMsg = sMsg & " And " & sField & oFlt.Criteria2
Case xlOr
sMsg = sMsg & " Or " & sField & oFlt.Criteria2
Case xlBottom10Items
sMsg = sMsg & " (bottom 10 items)"
Case xlBottom10Percent
sMsg = sMsg & " (bottom 10%)"
Case xlTop10Items
sMsg = sMsg & " (top 10 items)"
Case xlTop10Percent
sMsg = sMsg & " (top 10%)"
End Select
End If
Next i

If msg = "" Then
' No filters are applied, so say so
sMsg = "The range " & oAF.Range.Address & " is not filtered."
Else
' Filters are applied, so show them
sMsg = "The range " & oAF.Range.Address & " is filtered by:" & sMsg
End If

' Display the message
MsgBox sMsg
End Sub

Works fine on my tests! I've changed a small part of it to support complex criteria:

' Get the standard filter criteria
If IsArray(oFlt.Criteria1) Then
    Dim x As Integer
    sMsg = sMsg & vbCrLf & sField
    For x = 1 To UBound(oFlt.Criteria1)
        sMsg = sMsg & "'" & oFlt.Criteria1(x) & "'"
    Next x
Else
    sMsg = sMsg & vbCrLf & sField & "'" & oFlt.Criteria1 & "'"
End If

Original link: http://www.vbaexpress.com/forum/archive/index.php/t-7564.html