将 Excel 筛选结果放入 VBA 数组

Question

我有一个 VBA 子例程，它过滤第 4 列中包含文本“SV-PCS7”的记录。如何将这些结果放入数组中？

Sub FilterTo1Criteria()
Dim xlbook As Excel.Workbook
Dim xlsheet As Excel.Worksheet
Dim ro As Integer
Set xlbook = GetObject("C:\07509\04-LB-06 MX-sv.xlsx")
Set xlsheet = xlbook.Sheets("04-LB-06 MX")
   With xlsheet

       .AutoFilterMode = False
       .Range("blockn").AutoFilter Field:=1, Criteria1:="SV-PCS7"

   End With

End Sub

Answer 1

在应用Range.AutoFilter Method并确定有可见单元格后，您需要使用xlCellTypeVisible通过Range.SpecialCells method的Range.Areas property。每个区域都有一行或多行要处理。

Sub FilterTo1Criteria()
    Dim a As Long, r As Long, c As Long, vals As Variant
    Dim xlSheet As Worksheet
    'Set xlbook = GetObject("C:\07509\04-LB-06 MX-sv.xlsx")
    Set xlSheet = Worksheets("04-LB-06 MX")
    With xlSheet
        If .AutoFilterMode Then .AutoFilterMode = False

        'With .Range("blockn")
        With .Cells(1, 1).CurrentRegion
            .AutoFilter Field:=1, Criteria1:="SV-PCS7"
            'step off the header row
            With .Resize(.Rows.Count - 1, .Columns.Count).Offset(1, 0)
                'check if there are visible cells
                If CBool(Application.Subtotal(103, .Cells)) Then
                    'dimension the array (backwards)
                    ReDim vals(1 To .Columns.Count, 1 To 1)
                    'loop through the areas
                    For a = 1 To .SpecialCells(xlCellTypeVisible).Areas.Count
                        With .SpecialCells(xlCellTypeVisible).Areas(a)
                            'loop through the rows in each area
                            For r = 1 To .Rows.Count
                                'put the call values in backwards because we cannot redim the 'row'
                                For c = LBound(vals, 1) To UBound(vals, 1)
                                    vals(c, UBound(vals, 2)) = .Cells(r, c).Value
                                Next c
                                'make room for the next
                                ReDim Preserve vals(1 To UBound(vals, 1), 1 To UBound(vals, 2) + 1)
                            Next r
                        End With
                    Next a
                End If
            End With
        End With

        If .AutoFilterMode Then .AutoFilterMode = False
    End With


    'trim off the last empty 'row'
    ReDim Preserve vals(1 To UBound(vals, 1), 1 To UBound(vals, 2) - 1)
    'reorient the array
    vals = Application.Transpose(vals)
    'show the extents
    Debug.Print LBound(vals, 1) & ":" & UBound(vals, 1)
    Debug.Print LBound(vals, 2) & ":" & UBound(vals, 2)

    'show the values
    For r = LBound(vals, 1) To UBound(vals, 1)
        For c = LBound(vals, 2) To UBound(vals, 2)
            Debug.Print vals(r, c)
        Next c
    Next r

End Sub

Preserve 选项可以与ReDim statement 一起使用，但只能重新调整最后一个范围。我以错误的方向构建了阵列，然后使用TRANSPOSE function 来翻转方向。注意：可以成功翻转的数组元素的数量是有限制的。

Answer 2

如果您想避免 Jeeped（优秀）解决方案的复杂循环，您可以使用临时表先复制可见行。

Sub test()
    Dim src As Range, m As Variant, sh As Worksheet

    Set src = Sheet1.Range("c3").CurrentRegion.SpecialCells(xlCellTypeVisible)
    Set sh = Worksheets.Add

    src.Copy sh.Range("a1")
    m = sh.Range("a1").CurrentRegion
    Application.DisplayAlerts = False
    sh.Delete
    Application.DisplayAlerts = True
    Debug.Print UBound(m)
End Sub

Answer 3

看起来最好的方法是遍历每一行，检查该行是否隐藏（cell.EntireRow.Hidden = False），如果该行没有隐藏，则将该行的数据添加到数组中。类似例子：Easiest way to loop through a filtered list with VBA?