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

[pauljspin]

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)    
        DoEvents
        
        ' 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
        Data.Select


        ' 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
                    Else
                    End If
                Next
            Next
        ' Close Workbook
        wb.Close SaveChanges:=False
        DoEvents
            
        ' Active workbook where data is to be stored
        OutWkBk.Activate
        ' Select "Admin" worksheet
        out.Select
        
        ' 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
                output.Rows(i).EntireRow.<wbr>Delete
            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
            
            Else
            
            End If
        Next
        
        
        .Calculation = x1CalculationAutomatic
        .ScreenUpdating = True
        
        End With
        
        Loop
        
    End Sub

 

[smpatty08]

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
ErrorHandler:
    '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.