excel - VBA Excel - Redim 循环中的二维数组

Question

我正在使用这个有效的代码，但我在数组末尾得到了很多空行:ary有没有办法调整大小ary循环内的数组以避免条件不满足的额外空行？

Dim myTable As ListObject
Dim myArray As Variant
Dim ary As Variant
Dim x As Long
Dim r As Long, nr As Long

Set myTable = x_sheet.ListObjects("accounts_table")
myArray = myTable.DataBodyRange

ReDim ary(1 To UBound(myArray), 1 To 2)
   
For x = LBound(myArray) To UBound(myArray)
   If myArray(x, 5) = "On" Then
   If myArray(x, 4) <> "T" Or myArray(x, 4) <> "I" Then
   nr = nr + 1
   ary(nr, 1) = myArray(x, 1)
   ary(nr, 2) = myArray(x, 2)
   End If
   End If
Next x

Answer 1

这是一种方法 - 首先计算(并收集)匹配的行，然后调整大小并填充您的数组。
编辑:更新以将数组过滤推送到一个独立函数中，该函数接受过滤每一行时要使用的函数的名称。

Sub TestArrayFiltering()
    
    Dim myTable As ListObject
    Dim myArray As Variant, ws As Worksheet, filtered
    
    Set ws = ActiveSheet
    
    Set myTable = ws.ListObjects("accounts_table")
    myArray = myTable.DataBodyRange
    
    'filter the array according to the function "MyRowmatch"
    filtered = Filter2DArray(myArray, "MyRowMatch")
    
    If Not IsEmpty(filtered) Then
        ws.Range("I2").Resize(UBound(filtered, 1), UBound(filtered, 2)).Value = filtered
    Else
        MsgBox "No matches"
    End If

End Sub

'do we want this "row" ?
Function MyRowMatch(arr, indx) As Boolean
    Dim v
    v = arr(indx, 4)
    MyRowMatch = (arr(indx, 5) = "On" And v <> "T" And v <> "I")
End Function

'Utility function: take a 2-d array and return a new array containing only rows which
'  return True from the function named in `func`
'  `func` must take 2 arguments - a 2D array and a row index
Function Filter2DArray(arrIn, func As String)

    Dim arrOut As Variant, matches As New Collection
    Dim x, col As Long, i As Long
    Dim lbr As Long, lbc As Long, ubr As Long, ubc As Long
    
    lbr = LBound(arrIn, 1) 'get input array bounds
    lbc = LBound(arrIn, 2)
    ubr = UBound(arrIn, 1)
    ubc = UBound(arrIn, 2)
    
    For x = lbr To ubr 'collect matching row indexes
        If Application.Run(func, arrIn, x) Then matches.Add x
    Next x
    'resize destination array and transfer matching rows
    If matches.Count > 0 Then
        ReDim arrOut(lbr To matches.Count + (lbr - 1), lbc To ubc)
        i = lbr
        For Each x In matches
            For col = lbc To ubc
                arrOut(i, col) = arrIn(x, col)
            Next col
            i = i + 1
        Next x
        Filter2DArray = arrOut
    Else
        Filter2DArray = Empty
    End If
End Function