主页 / coding / 问题 / 79349954
Accepted
Leo Zayas
Asked: 2025-01-12 21:18:01 +0800 CST

如何将可见的过滤数据从表传输到多维数组中？

  • 772

我有一个名为“销售跟踪器”的表格，我进行了自动过滤并获得了结果。现在我想将可见字段转移到我的数组 soArray 中，第一次浏览单元格时，它工作正常，我将需要的 4 个字段放入数组中，但是，第一次出现“运行时错误'9'：下标超出范围”后，我做错了什么？任何帮助或推动都将不胜感激，谢谢以下是我的代码

    Sub getAllSO()

    Dim wkb As Workbook
    Dim wks As Worksheet
    
    Set wkb = Workbooks("ScrubCentral.xlsm")
    Set wks = wkb.Sheets("Sales Tracker")
    
    Dim tbl As ListObject
    Set tbl = wks.ListObjects("SalesTracker")
    tbl.AutoFilter.ShowAllData
    
    tbl.Range.AutoFilter field:=4, Criteria1:=">0"
    
    Dim soArray() As Variant
    Dim rngVisible As Range
    Dim i As Long
    Dim rCell As Range
    
    With wks
        With .AutoFilter.Range
            Set rngVisible = .Offset(1, 0).Resize(.Rows.Count - 1, 1) _
                  .SpecialCells(xlCellTypeVisible)
        End With
        
        For Each rCell In rngVisible
            i = i + 1
            ReDim Preserve soArray(1 To i, 1 To 4)
            soArray(i, 1) = rCell(i, 2)
            soArray(i, 2) = rCell(i, 3)
            soArray(i, 3) = rCell(i, 4)
            soArray(i, 4) = rCell(i, 13)
            Debug.Print soArray(i, 1), soArray(i, 2), soArray(i, 3), soArray(i, 4)
        Next rCell
    End With
    
End Sub
arrays

1 个回答

  1. Best Answer
    1. 如果使用Preserve关键字，则只能调整 的大小last array dimension。

    Microsoft 文档：

    ReDim 语句

    1. For Each rCell In rngVisible相当于For Each rCell In rngVisible.Cells并且不会按您预期提取数据。

    2. 此外，过滤表 ( ListObject) 通常由不连续的范围组成。为了正确处理这种情况，脚本需要嵌套For Each循环。

    Sub getAllSO()
    Dim wkb As Workbook
    Dim wks As Worksheet
    Set wkb = Workbooks("ScrubCentral.xlsm")
    Set wks = wkb.Sheets("Sales Tracker")
    Dim tbl As ListObject
    ' Set wks = ActiveSheet ' for debugging
    Set tbl = wks.ListObjects("SalesTracker")
    tbl.AutoFilter.ShowAllData
    tbl.Range.AutoFilter field:=4, Criteria1:=">0"
    Dim soArray() As Variant
    Dim rngVisible As Range
    Dim i As Long
    With wks
        With .AutoFilter.Range
            Set rngVisible = tbl.DataBodyRange.SpecialCells(xlCellTypeVisible)
        End With
        Dim rArea As Range, rRow As Range
        For Each rArea In rngVisible.Areas
            For Each rRow In rArea.Rows
                i = i + 1
                ReDim Preserve soArray(1 To 4, 1 To i)
                soArray(1, i) = rRow.Cells(2)
                soArray(2, i) = rRow.Cells(3)
                soArray(3, i) = rRow.Cells(4)
                soArray(4, i) = rRow.Cells(13)
            Next
        Next
    End With
    ' for testing
    Sheets.Add
    Range("A1").Resize(i, 4).Value = Application.Transpose(soArray)
End Sub

    如果脚本中的过滤条件如上所述简单明了，则另一种方法可能是将表加载到数组中并使用 VBA 应用过滤逻辑。

    Sub getAllSO2()
    Dim wkb As Workbook
    Dim wks As Worksheet
    Set wkb = Workbooks("ScrubCentral.xlsm")
    Set wks = wkb.Sheets("Sales Tracker")
    Dim tbl As ListObject
'    Set wks = ActiveSheet ' for debugging
    Set tbl = wks.ListObjects("SalesTracker")
    tbl.AutoFilter.ShowAllData
    Dim loArray: loArray = tbl.DataBodyRange.Value
    Dim soArray() As Variant
    Dim i As Long, j As Long
    Const KEY_COL = 4
    For j = LBound(loArray) To UBound(loArray)
        If loArray(j, KEY_COL) > 0 Then ' filtering table
            i = i + 1
            ReDim Preserve soArray(1 To 4, 1 To i)
            soArray(1, i) = loArray(j, 2)
            soArray(2, i) = loArray(j, 3)
            soArray(3, i) = loArray(j, 4)
            soArray(4, i) = loArray(j, 13)
        End If
    Next
    ' for testing
    Sheets.Add
    Range("A1").Resize(i, 4).Value = Application.Transpose(soArray)
End Sub

    重复语句的替代方法ReDim是预先分配足够的数组空间，以避免频繁调整大小。

    Sub getAllSO3()
    Dim wkb As Workbook
    Dim wks As Worksheet
    Set wkb = Workbooks("ScrubCentral.xlsm")
    Set wks = wkb.Sheets("Sales Tracker")
    Dim tbl As ListObject
'    Set wks = ActiveSheet ' for debugging
    Set tbl = wks.ListObjects("SalesTracker")
    tbl.AutoFilter.ShowAllData
    Dim loArray: loArray = tbl.DataBodyRange.Value
    Dim soArray() As Variant
    Redim soArray(1 To UBound(loArray), 1 to 4)
    Dim i As Long, j As Long
    Const KEY_COL = 4
    For j = LBound(loArray) To UBound(loArray)
        If loArray(j, KEY_COL) > 0 Then ' filtering table
            i = i + 1
            ReDim Preserve soArray(1 To 4, 1 To i)
            soArray(i, 1) = loArray(j, 2)
            soArray(i, 2) = loArray(j, 3)
            soArray(i, 3) = loArray(j, 4)
            soArray(i, 4) = loArray(j, 13)
        End If
    Next
    ' for testing
    Sheets.Add
    Range("A1").Resize(i, 4).Value = soArray
End Sub
    • 1

相关问题