Excel VBA - How do you add a row to a 2d variant array while preserving old array values?

user_15868798 0
Viewed 1316

I have tried and looked everywhere. Cannot figure this out. I have a 1 row table with 7 columns and I am reading the values into an array.

Then I want to add a row at some point in my code to that array, while preserving the old values from the array. Here is the code:

Dim arr As Variant

arr = Worksheets(worksheet).ListObjects(table).DataBodyRange

This "arr" is now a 2d array, with 1 row and 7 columns and it loads the data fine.

Later on in my code I want to add a row to this array so I try this:

ReDim Preserve arr(1 To 2, 1 To 7) As Variant

Gives me a "subscript out of range" error.

How do add a row to this type of array while preserving the other values in it?

Thanks all. This is driving me crazy.

vba excel arrays
3 Answers

You can only change the size of the last dimension when using ReDim Preserve.

So to do what you want make the dimension you want to change the last dimension by using Application.Transpose, redimension and then transpose again.

Dim arr As Variant

arr = Worksheets(worksheet).ListObjects(table).DataBodyRange

' swap the row/column dimensions
arr = Application.Transpose(arr)

' resize the last, row, dimension
ReDim Preserve arr(1 To 7, 1 To 2)

' swap the row/column dimensions back
arr = Application.Transpose(arr)
user_28500260

Alternative via Application.Index() function

Just to show another approach in addition to @norie 's valid solution, I demonstrate how to profit from the advanced restructuring features of Application.Index():

Sub ExampleCall()
    Dim arr As Variant
    arr = Sheet1.ListObjects("Table").DataBodyRange   ' << change to your needs
    'add one new array row
    AddRowsToArr arr, 1                               ' << call help procedure
    
    Debug.Print "New dimension: arr(" & _
        LBound(arr, 1) & " To " & UBound(arr, 1) & ", " & _
        LBound(arr, 2) & " To " & UBound(arr, 2) & ")"
    Debug.Print arr(UBound(arr), 2)
End Sub

Help procedure AddRows

Sub AddRowsToArr(arr, Optional ByVal nRows As Long = 1, Optional overwrite As Boolean = True)
'define arrays of needed row and column numbers
    Dim r, c
    r = Evaluate("row(1:" & CStr(nRows + UBound(arr) - LBound(arr) + 1) & ")")
    c = Application.Transpose(Evaluate("row(1:" & CStr(UBound(arr, 2) - LBound(arr, 2) + 1) & ")"))
    '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    'redimension array to new size
    '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    arr = Application.Index(arr, r, c)

    '*) optional overwriting added row elements with Empty ~~> see Note below!
    '...
End Sub

Note If you want to return empty elements in the added row(s), overwrite the added row elements (containing temporary error values) by inserting the following code lines*; of course you could enter values in the calling procedure, too.*

    'overwrite added row elements with Empty
    If overwrite Then
        Dim rowNum As Long, colNum As Long
        For rowNum = UBound(arr) - nRows + 1 To UBound(arr)
            For colNum = LBound(arr, 2) To UBound(arr, 2)
                arr(rowNum, colNum) = Empty
            Next colNum
        Next rowNum
    End If
user_64602970

Append Array to Array

  • The appendData procedure will cover any number of rows (and/or columns).
Option Explicit

Sub appendDataTEST()
    
    Const wsName As String = "Sheet1"
    Const tblName As String = "Table1"
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
    Dim tbl As ListObject: Set tbl = ws.ListObjects(tblName)
    Dim Data As Variant: Data = tbl.DataBodyRange.Rows(1).Value
    
    ' Add the second data row (headers excluded) of the table.
    Dim NewData As Variant: NewData = tbl.DataBodyRange.Rows(2).Value
    appendData Data, NewData
    ' Or just:
    'appendData Data, tbl.DataBodyRange.Rows(2).Value
    
    ' Write the result to a new workbook:
'    With Workbooks.Add.Worksheets(1)
'        .Range("A1").Resize(UBound(Data, 1), UBound(Data, 2)).Value = Data
'        .Parent.Saved = True ' only to easily close
'    End With
    
End Sub

' Purpose:      'Appends' the values of one (new) array to an existing
'               (initial) array.
' Remarks:      It actually writes the values of both arrays to a new array
'               and 'replaces' the initial array with it.
'               It is assumed that both are 2D one-based arrays.
'               The number of rows of the 'resulting' array will be equal
'               to the sum of the rows of both arrays.
'               The number of columns of the 'resulting' array will be
'               equal to the number of the columns of the initial array.
'               If the number of columns of the new array is greater,
'               the data in the remaining columns will not be appended.
Sub appendData( _
        ByRef Data As Variant, _
        ByVal NewData As Variant)
    
    Dim rCount As Long: rCount = UBound(Data, 1) + UBound(NewData, 1)
    Dim cCount As Long: cCount = UBound(Data, 2)
    Dim rData As Variant: ReDim rData(1 To rCount, 1 To cCount)
    
    Dim r As Long, c As Long, n As Long
    For r = 1 To UBound(Data, 1)
        n = n + 1
        For c = 1 To cCount
            rData(n, c) = Data(r, c)
        Next c
    Next r
    
    If UBound(NewData, 2) < cCount Then
        cCount = UBound(NewData, 2)
    End If
    
    For r = 1 To UBound(NewData, 1)
        n = n + 1
        For c = 1 To cCount
            rData(n, c) = NewData(r, c)
        Next c
    Next r
    
    Data = rData

End Sub
user_98140690
Related