VBA Excel - Redim 2-D Array in Loop

Question

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

One option is to actually determine the target size of the array beforehand using WorksheetFunction.CountIfs. ReDim is expensive and shouldn't be done inside a loop. But more importantly, ReDim Preserve only allows one to modify the last array dimension, so it wouldn't work with your current array setup. — BigBen
– BigBen, Commented Mar 11, 2021 at 15:18

Tim Williams · Accepted Answer · 2021-03-11 21:23:20Z

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

Collectives™ on Stack Overflow

VBA Excel - Redim 2-D Array in Loop

1 Answer 1

Comments

Your Answer

Linked

Hot Network Questions

Collectives™ on Stack Overflow

1 Answer 1

Comments

Your Answer

Sign up or log in

Post as a guest

Linked

Related