获取自动筛选排序标准并应用于第二张纸

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 甚至不显示任何 AutoFilter 属性。有人可以阐明这一点吗？

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

改编自 ozgrid< /a>

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