VBA Excel - Redim 2-D Array in Loop

user_2092236 0
Viewed 62

I am using this code which works but I am getting a lot of empty lines at the end of the array: ary

Is there a way to resize ary array inside the loop to avoid the extra blank lines not met by the conditions?

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
vba excel
1 Answers

Here's one approach - first count (and collect) the matching rows, then resize and fill your array.

EDIT: updated to push the array filtering into a standalone function which accepts the name of the function to be used when filtering each row.

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
user_4788840
Related