多小区AutoFilter

Question

我有一个在C列中选择非空单元格的代码。现在，如果我想在我的自动筛选器中选择这些单元格，它只显示OutRng的第一个找到的值。我该怎么解决这个问题？

Sub SelectNonBlankCells()

    Sheets("Rekenblad").Select

    Dim Rng As Range
    Dim OutRng As Range
    Dim xTitle As String
    SearchCol = "10"

    On Error Resume Next

    xTitle = Range("C:C")
    Set InputRng = Range("C:C")

    For Each Rng In InputRng
        If Not Rng.Value = "" Then
            If OutRng Is Nothing Then
                Set OutRng = Rng
            Else
                Set OutRng = Application.Union(OutRng, Rng)
            End If
        End If
    Next

    If Not (OutRng Is Nothing) Then
        OutRng.Copy

        Sheets("Plakken").Select
        ActiveSheet.Range("$A$1:$K$13").AutoFilter Field:=10, Criteria1:=Array(OutRng) _
            , Operator:=xlFilterValues
    End If
End Sub

Answer 1

多个值(数组)上的AutoFilter

• Range("C:C")是一个相当大的范围，得到processed.
• OutRng.Copy可能需要很长时间，除非您计划复制它-- somewhere.
• Since OutRng声明为range，Array(OutRng)是包含一个元素的数组，它是实际的范围(对象，而不是值)。如果一个区域包含多个单元格，并且是连续的(一个范围，一个区域)，则为
• ，您可以使用OutRng.Value，但这是一个基于2D的一维数组，在本例中(它是一列数组)可以使用Application.Transpose(OutRng.Value)将其转换为基于一维的数组。但是，由于你已经将不同的细胞组合成一个范围，预计范围是不连续的(有几个区域，是一个多区域)，你又陷入了死胡同。
• 无论如何，这是一个有趣的尝试(IMHO)。

Option Explicit

Sub FilterRange()
    
    ' Source
    Const sName As String = "Rekenblad"
    Const sCol As String = "C"
    Const sfRow As Long = 2
    ' Destination
    Const dName As String = "Plakken"
    Const dField As Long = 10
    ' Workbook
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Create a reference to the Source Range ('srg').
    Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
    'If sws.AutoFilterMode Then sws.AutoFilterMode = False
    Dim slRow As Long: slRow = sws.Cells(sws.Rows.Count, sCol).End(xlUp).Row
    Dim srCount As Long: srCount = slRow - sfRow + 1
    If srCount < 1 Then Exit Sub ' no data
    Dim srg As Range: Set srg = sws.Cells(sfRow, sCol).Resize(srCount)
    
    ' Write the values from the Source Range to the Source Array ('sData').
    Dim sData As Variant
    If srCount = 1 Then ' one cell
        ReDim sData(1 To 1, 1 To 1): sData(1, 1) = srg.Value
    Else ' multiple cells (in column)
        sData = srg.Value
    End If
    
    ' Write the unique values from the Source Array to the keys
    ' of a dictionary ('dict').
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare ' A = a
    Dim Key As Variant
    Dim r As Long
    For r = 1 To srCount
        Key = sData(r, 1)
        If Not IsError(Key) Then ' not error value
            If Len(Key) > 0 Then ' not blank
                dict(CStr(Key)) = Empty
            'Else ' blank
            End If
        ' Else ' error value
        End If
    Next r
    If dict.Count = 0 Then Exit Sub ' only blanks and error values

    ' Filter the Destination Range ('drg') by the values in the dictionary.
    Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
    If dws.AutoFilterMode Then dws.AutoFilterMode = False ' remove previous
    Dim drg As Range: Set drg = dws.Range("A1").CurrentRegion
    ' If the previous line doesn't work, use another way,
    ' or revert to the static:
    'Set drg = dws.Range("A1:K13")
    drg.AutoFilter dField, dict.Keys, xlFilterValues
    'dws.activate

End Sub