Início / coding / Perguntas / 79349954
Accepted
Leo Zayas
Asked: 2025-01-12 21:18:01 +0800 CST

Como posso transferir dados filtrados visíveis de uma tabela para uma matriz multidimensional?

  • 772

Tenho uma tabela chamada "Rastreador de vendas". Fiz um filtro automático e obtive meus resultados. Agora, quero transferir os campos visíveis para minha matriz chamada soArray. Na primeira vez que passo pelas células, funciona bem e coloco os 4 campos de que preciso na matriz. No entanto, após a primeira vez, recebo um "Erro de tempo de execução '9': Subscrito fora do intervalo". O que estou fazendo errado? Qualquer ajuda ou incentivo seria apreciado. Obrigado. Abaixo está meu código.

    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 respostas

  1. Best Answer
    1. Se você usar a Preservepalavra-chave, poderá redimensionar apenas o last array dimension.

    Documentação da Microsoft:

    Declaração ReDim

    1. For Each rCell In rngVisibleé equivalente For Each rCell In rngVisible.Cellse não extrai dados como você esperava.

    2. Além disso, uma tabela filtrada ( ListObject) frequentemente consiste em intervalos não contíguos. Para lidar com isso corretamente, o script requer For Eachloops aninhados.

    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

    Se os critérios de filtragem em seu script forem tão simples quanto mostrado, uma abordagem alternativa poderia ser carregar a tabela em uma matriz e aplicar a lógica de filtragem usando 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

    Uma alternativa para ReDiminstruções repetidas é pré-alocar espaço de array suficiente para evitar redimensionamentos frequentes.

    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

relate perguntas