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

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

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

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

Я пробовал сделать что-то вроде этого (мне пришлось добавить формулу 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 даже не обнаруживает никаких свойств AutoFilter. Может ли кто-нибудь пролить свет на это?


sorting excel vba autofilter
person Kenny Bones    schedule 14.10.2011    source источник

Ответы (3)


arrow_upward
2
arrow_downward

Вот способ получить 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

Адаптировано из ozgrid

person JMax    schedule 14.10.2011

arrow_upward
1
arrow_downward

Вот несколько заметок о том, что я считаю вашими требованиями.

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
person Fionnuala    schedule 14.10.2011

arrow_upward
0
arrow_downward

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

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

person Tomamais    schedule 28.01.2016