How can I dynamically increase the number of rows in an array when new data is available to assign to the array


New Member
Oct 9, 2018
I am using the VBA code below to copy elements from a semi-structured workbook to an array and then from the array into a target worksheet of another workbook. My problem is that the macro takes a long time to run and (sometimes) causes Excel to freeze.

My approach is to define an empty 2D array. I set the number of columns equal to the number of variables to be collected. I set a very large number of "rows" because I don't know in advance how many rows I'll need. As a result I end up copying a large number of empty rows to the target worksheet. I then delete the rows, which takes time. I suspect one solution would be to dynamically modify the number of rows in the array as needed, but I am not quite sure how to do this.

Here is my sample code:

Sub Fetch() ' Opens messy worksheet of medication admins and office visits
        Dim wb As Workbook, OutWkBk As Workbook ' Workbooks
        Dim wd As String, file As String ' Working directory and file name
        Dim Data As Worksheet, out As Worksheet  ' Worksheets
        Dim rng As Range ' Worksheet range
        ' Set Active Workbook
        Set OutWkBk = ActiveWorkbook
        ' Make "Admins" sheet the active workbook
        Set out = ThisWorkbook.Sheets("Admins")
        ' File path of target semi-structured workbook
        file = wd + "/HOA-EVENT-DETAIL-2003-<wbr>PRESCRIPTION-ADMIN-August2018.<wbr>xls"
        ' Open workbook and set wb
        Set wb = Workbooks.Open(Filename:=wd & file2)    
        ' Select first worksheet of workbook
        Set Data = wb.Sheets(1)
        ' Count rows in active workbook
        nr = Data.Cells(Data.Rows.Count, "A").End(xlUp).Row + 1
        ' Count columns in active workbook
        nc = Data.Cells(8, Data.Columns.Count).End(<wbr>xlToLeft).Column + 1
        ' Define an array
        Const nrow As Integer = 30000, ncol As Integer = 24
        Dim c(nrow, ncol) As String
        ' Activate first worksheet of active workbook

        ' Populate array from active worksheet
        ' Initial array row
        RowIndex = 0
            For Row = 1 To nrow ' Outer loop over rows of worksheet
                For Col = 1 To 30 ' Inner loop over columns of worksheet
                    If Cells(Row, Col).Value = "FULL NAME:" Then
                        c(RowIndex, 0) = Cells(Row, Col + 4).Value
                    ElseIf Cells(Row, Col).Value = "EXAM SCHOOL:" Then
                        c(RowIndex, 1) = Cells(Row, Col + 7).Value
                    ' Many other ElseIfs go here
                    End If
        ' Close Workbook
        wb.Close SaveChanges:=False
        ' Active workbook where data is to be stored
        ' Select "Admin" worksheet
        ' Set Worksheet Range
        Set rng = Range(Cells(2, 1), Cells(nrow + 1, ncol + 1))
        ' Transfer array to worksheet
        rng.Value = c
        'Delete empty rows
        Dim i As Long
        With Application
            .Calculation = x1CalculationManual
            .ScreenUpdating = False
        For i = out.Rows.Count To 1 Step -1
            If WorksheetFunction.CountA(<wbr>output.Rows(i)) = 0 Then
            End If
        Next i

        ' Fill in blanks in the names column
        For r = 2 To out.Rows.Count - 1
            If IsEmpty(Cells(r, 1).Value) = False And IsEmpty(Cells(r + 1, 1).Value) = True Then
                Cells(r + 1, 1) = Cells(r, 1).Value
            ElseIf x Then Exit For
            End If
        .Calculation = x1CalculationAutomatic
        .ScreenUpdating = True
        End With
    End Sub
Last edited by a moderator:

Some videos you may like

Excel Facts

Best way to learn Power Query?
Read M is for (Data) Monkey book by Ken Puls and Miguel Escobar. It is the complete guide to Power Query.


Board Regular
May 16, 2014
You could use this function to count the number of rows so you can set the size of your array appropriately.
Function ActualUsedRange(MySheet As Worksheet) As Range
    Dim FirstCell As Range, LastCell As Range
    'Go to the ErrorHandler line if an error occurs such as no data in the worksheet
    On Error GoTo ErrorHandler
    With MySheet
        'Find the last cell
        Set LastCell = .Cells(.Cells.Find(What:="*", SearchOrder:=xlRows, _
            SearchDirection:=xlPrevious, LookIn:=xlValues).Row, _
            .Cells.Find(What:="*", SearchOrder:=xlByColumns, _
            SearchDirection:=xlPrevious, LookIn:=xlValues).Column)
        'Find the first cell
        Set FirstCell = .Cells(.Cells.Find(What:="*", After:=LastCell, SearchOrder:=xlRows, _
            SearchDirection:=xlNext, LookIn:=xlValues).Row, _
            .Cells.Find(What:="*", After:=LastCell, SearchOrder:=xlByColumns, _
            SearchDirection:=xlNext, LookIn:=xlValues).Column)
        'Set what the actual range is
        Set ActualUsedRange = .Range(FirstCell, LastCell)
    End With
    'Exits the function so the error handler isn't called every time
    Exit Function
    'Sets the range to cell A1 of the worksheet if no data is in the worksheet
    Set ActualUsedRange = MySheet.Range("A1")
End Function

You would still need to use your same blank row deletion part of your code, but it wouldn't have to cycle through all the empty rows at the end of your range.
Last edited by a moderator:

Watch MrExcel Video

Forum statistics

Latest member

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back