Получить критерии сортировки автофильтра и применить на втором листе

Question

Я пытаюсь выяснить, могу ли я программно перехватить событие сортировки автофильтра, получить критерии сортировки и затем применить те же критерии сортировки к автофильтру во втором листе.

Пока мне кажется, что я должен вызвать событие Worksheet_Calculate (). И это я сделал. Затем я должен проверить, были ли изменены критерии сортировки автофильтра. Если это не так, выйдите из sub. Если это так, соберите критерии и проведите их через отдельную подпрограмму, которая выполняет ту же самую сортировку на автофильтре в отдельной рабочей таблице.

Общая идея заключается в том, что всякий раз, когда один из этих двух автофильтров сортируется, автофильтр на другом листе должен сортироваться точно так же.

Я пытался сделать что-то подобное (мне пришлось добавить формулу Excel, чтобы фактически вызвать триггер вычисления события):

Private Sub Worksheet_Calculate()
     Dim wbBook as Workbook
     Dim wsSheet as Worksheet
     Dim rnData as Range

     Set wbBook = ThisWorkbook
     Set wsSheet = wbBook.Worksheets("Sheet1")

     With wsSheet
          Set dnData = .UsedRange
     End With
End Sub

Но мне не удается собрать критерии, я пробовал несколько вещей, и добавление часов в dnData даже не обнаруживает никакого свойства автофильтра. Может кто-нибудь пролить свет на это?

Answer 1

Вот способ получить критерии autofilter:

Sub test()
Dim Header As Range
Dim sMainCrit As String, sANDCrit As String, sORCrit As String
Set Header = Range("A2:C2")
    With Header.Parent.AutoFilter
        With .Filters(Header.Column - .Range.Column + 1)
            If Not .On Then
                MsgBox ("no criteria")
                Exit Sub
            End If
            sMainCrit = .Criteria1
            If .Operator = xlAnd Then
                sANDCrit = .Criteria2
            ElseIf .Operator = xlOr Then
                sORCrit = .Criteria2
            End If
        End With
    End With
    MsgBox ("Main criteria: " & sMainCrit & Chr(13) & "AND Criteria:" & sANDCrit & Chr(13) & "OR Criteria" & sORCrit)
End Sub

Адаптировано с озгрид

Answer 2

Вот некоторые заметки о том, что я вижу в ваших требованиях.

Dim rv As AutoFilter ''Object
Set rv = Sheet1.AutoFilter

''Just for curiosity
Debug.Print rv.Sort.Header
Debug.Print rv.Sort.SortFields.Count
Debug.Print rv.Sort.SortFields.Item(1).SortOn
Debug.Print rv.Sort.Rng.Address
Debug.Print rv.Sort.SortFields.Item(1).Key.Address

''One key only, but it is easy enough to loop and add others
Sheet2.Range(rv.Sort.Rng.Address).Sort _
    key1:=Sheet2.Columns(rv.Sort.SortFields(1).Key.Column), _
    Header:=xlYes

Answer 3

Нашел этот код:

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

Отлично работает на моих тестах!Я изменил небольшую часть для поддержки сложных критериев:

' 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

Исходная ссылка: http://www.vbaexpress.com/forum/archive/index.php/t-7564.html