自动过滤已经自动过滤的列

问题描述 投票：0回答：2

我正在通过使用 

dictionary
来使用自定义自动过滤器，如下面的代码所示。
现在，我需要在 already filtered column 上设置一个 additional autofilter。
例如第一个自动过滤器的结果是 ("
ID 20 , Name30 , Color 35 , ID39
"),
在第二个自动过滤器上，我需要过滤一个包含例如“
*30*
”.
我需要在第二个单独的步骤中完成，我的意思是，在按照我尝试的方式放置第一个过滤器然后完全关闭该工作簿（雄辩）之后，我需要在已经过滤的范围内应用第二个过滤器, 由包含 30 的单元格组成。或意思是仅对可见单元格上的数据应用过滤器。
注意，我不喜欢使用辅助列/表，
并且还想保持我的代码不变，这意味着我寻求额外的子。
提前，非常感谢您的帮助。

Option Explicit
Option Compare Text

Sub Filter_the_Filtered_Column()

    Const filter_Column As Long = 2
    
    Dim filter_Criteria() As Variant
    filter_Criteria = Array("*Id*", "*Name*", "*Color*")
    
    Dim ws As Worksheet:    Set ws = ActiveSheet
    
    If ws.AutoFilterMode Then ws.AutoFilterMode = False
    
    Dim rg As Range
    Set rg = ws.UsedRange.Resize(ws.UsedRange.Rows.count - 1).Offset(1)  '(UsedRange except the first Row)
    
    Dim rCount As Long, arr() As Variant, dict As Object, el, r As Long
    rCount = rg.Rows.count - 1
    arr = rg.Columns(filter_Column).Resize(rCount).Offset(1).value         'Write the values from criteria column to an array.
        
    Set dict = CreateObject("Scripting.Dictionary")                        'Write the matching strings to the keys (a 1D array) of a dictionary.
 
    For r = 1 To UBound(arr)                                                'Loop through the elements of the array.
        For Each el In filter_Criteria
            If arr(r, 1) Like el Then dict(arr(r, 1)) = vbNullString: Exit For
        Next el
    Next r
    
    If dict.count > 0 Then
        rg.AutoFilter Field:=filter_Column, Criteria1:=dict.Keys, Operator:=xlFilterValues   'use the keys of the dictionary (a 1D array) as a Criteria
    End If

End Sub
arrays excel vba dictionary autofilter
2个回答
1
投票

如果你确实想要它作为一个单独的子，你可以试试这个：

Sub filteredRangeToArray()
    Const filter_Column As Long = 2
    
    Dim ws As Worksheet, arr(), rng As Range, newSh As Worksheet
    Dim lRow As Long, r As Long
    Dim nFilter As String: nFilter = "30"
    Dim dict As Object
    
    Set ws = ActiveWorkbook.ActiveSheet
    lRow = ws.Range("A" & Rows.Count).End(xlUp).Row
    Set rng = ws.Range("A2:A" & lRow).SpecialCells(xlCellTypeVisible)
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Set newSh = Worksheets.Add
    rng.Copy newSh.Range("A1")
    arr = newSh.Range("A1:A" & rng.Count).Value
    newSh.Delete
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    
    Set dict = CreateObject("Scripting.Dictionary")
    For r = 1 To UBound(arr, 1)
        If arr(r, 1) Like nFilter Then dict(arr(r, 1)) = vbNullString
    Next r
    
    If dict.Count > 0 Then
        rg.AutoFilter Field:=filter_Column, Criteria1:=dict.Keys, Operator:=xlFilterValues   'use the keys of the dictionary (a 1D array) as a Criteria
    End If
End Sub

但现在我看到 FaneDuru 关于使 dict 成为全局变量的评论，当然它可能会更快/更容易。当你不想使用它时，我会留下我的答案。

编辑：

Sub filteredRangeToArray_V2()
    Const filter_Column As Long = 2
    
    Dim ws As Worksheet, arr(), rng As Range, newSh As Worksheet
    Dim lRow As Long, r As Long
    Dim nFilter As String: nFilter = "*30*"
    Dim dict As Object
    Dim ccell As Range
    
    Set ws = ActiveWorkbook.ActiveSheet
    lRow = ws.Range("A" & Rows.Count).End(xlUp).Row
    Set rng = ws.Range("A2:A" & lRow).Offset(0, filter_Column - 1).SpecialCells(xlCellTypeVisible)
    
    ReDim arr(1 To rng.Count)
    r = 1
    For Each ccell In rng.Cells
        arr(r) = ccell.Value
        r = r + 1
    Next ccell
    Set dict = CreateObject("Scripting.Dictionary")
    For r = 1 To UBound(arr, 1)
        If arr(r) Like nFilter Then dict(arr(r)) = vbNullString
    Next r
    
    Set rng = ws.UsedRange.Resize(ws.UsedRange.Rows.Count)
    rng.Select
    If ws.AutoFilterMode Then ws.AutoFilterMode = False
    If dict.Count > 0 Then
        rng.AutoFilter Field:=filter_Column, Criteria1:=dict.Keys, Operator:=xlFilterValues   'use the keys of the dictionary (a 1D array) as a Criteria
    End If
End Sub

这应该适应不需要另一张纸/帮助列。

1
投票

有点忙没有时间等我的澄清问题的答案，抱歉...

看起来足以改变：

     For r = 1 To UBound(arr)                                                'Loop through the elements of the array.
        For Each el In filter_Criteria
            If arr(r, 1) Like el Then dict(arr(r, 1)) = vbNullString: Exit For
        Next el
    Next r

与：

    For r = 1 To UBound(arr)                                                
        For Each El In filter_Criteria
            If arr(r, 1) Like El And arr(r, 1) Like Second_filter Then dict(arr(r, 1)) = vbNullString: Exit For
        Next El
    Next r

当然，

Second_filter
是一个字符串变量，保留你想要的（“30”）......

即使它会在第一个过滤器之后运行（作为您现有代码的结果），它也将作为第二步运行。

如果你想让它更快，你可以将 

dict
声明为全局变量（在模块顶部）并从现有代码中删除声明。

然后，在第二步中使用它，在另一个字典中过滤...

为此，请测试下一个代码：

Sub Filter_the_Filtered_Column_After()
    Const filter_Column As Long = 2
    Dim Second_filter As String: Second_filter = "*30*"
    
    Dim ws As Worksheet:    Set ws = ActiveSheet
    
    If ws.AutoFilterMode Then ws.AutoFilterMode = False
        
    Dim rg As Range
    Set rg = ws.UsedRange.Resize(ws.UsedRange.rows.count - 1).Offset(1)  '(UsedRange except the first Row)
    
    Dim r As Long, dict2 As Object
    Set dict2 = CreateObject("Scripting.Dictionary")                        'Write the matching strings to the keys (a 1D array) of a dictionary.
 
    For r = 0 To UBound(dict.keys)                                         'Loop through the elements of the array.
        If dict.keys()(r) Like Second_filter Then dict2(dict.keys()(r)) = vbNullString
    Next r

    If dict.count > 0 Then
        rg.AutoFilter field:=filter_Column, Criteria1:=dict2.keys, Operator:=xlFilterValues   'use the keys of the dictionary (a 1D array) as a Criteria
    End If

End Sub

当然，你应该初步检查

not dict is nothing
，如果没有加载字典就运行上面的代码，或者同时运行的中间程序出现错误，你必须关闭它......

已编辑：

为了提取过滤器使用的数组，如果您不知道（如您在评论中所问，请使用下一个功能：

Function extractFiltCriteria(sht As Worksheet, filtCol As Long) As Variant
    Dim arrFilt(), i As Long, fltRange As String
    
    If sht.AutoFilterMode = False Then Exit Function
    
    With sht.AutoFilter
        fltRange = .Range.address
        With .Filters
            With .Item(filtCol)
                If .On Then
                    If IsArray(.Criteria1) Then
                        If .Operator = xlFilterValues Then
                            If IsArray(.Criteria1) Then extractFiltCriteria = Array(fltRange, .Criteria1, .Operator)
                        End If
                    End If
                End If
            End With
        End With
    End With
End Function

可以在下一个适配的代码中使用：

Sub Filter_the_Filtered_Column2()
   Dim filter_Criteria(), ws As Worksheet
   Const col As Long = 2, Second_filter As String = "*30*"
   
   Set ws = ActiveSheet
   
   If ws.AutoFilterMode = False Then MsgBox "No filter applied...": Exit Sub
   filter_Criteria = extractFiltCriteria(ws, col) 'extract filtered range, filter array and filter Operator
    
    Dim dict As Object, arr, El, mtch, r As Long
    Set dict = CreateObject("Scripting.Dictionary")
    
    arr = ws.Range(filter_Criteria(0)).Value2 'place in the array the extracted range which was previously filtered
    
    For r = 2 To UBound(arr)
        mtch = Application.match("=" & arr(r, col), filter_Criteria(1), 0)            'check if the array element matches the extracted filtering array
        If Not IsError(mtch) Then
            If arr(r, col) Like Second_filter Then dict(arr(r, col)) = vbNullString 'if a match exists and the array element contains Second_filter string
        End If
    Next r
     
     'refilter by the new dict.keys array:
    ws.Range(filter_Criteria(0)).AutoFilter col, dict.keys, Operator:=filter_Criteria(2)
End Sub

请测试它并发送一些反馈。应该是极快的……

但是该函数完全处理这种情况：第二列中的数组过滤器。它可以被开发来满足所有可能的情况，但它会复杂得多......

最新问题
© www.soinside.com 2019 - 2024. All rights reserved.