CODEWITHSUNDEEP
excelvba
L. Ouellet
L. Ouellet

Reputation: 133

Excel freezing when importing many rows

I created a macro to import multiple spreadsheet into on master report. I tested it with some small files without any issues. But when I am trying to import a file with more then just a couple of rows, excel keeps freezing.

Sub openFile(ByRef file As String)
    Dim wbMaster As Workbook: Set wbMaster = ThisWorkbook
    Dim wsMaster As Worksheet: Set wsMaster = wbMaster.Sheets("Report")
    Dim tbMaster As ListObject: Set tbMaster = wsMaster.ListObjects("Report")
    Dim hdrMaster As ListColumn
    Dim rowMaster As ListRow
    Dim wbSlave As Workbook: Set wbSlave = Workbooks.Open(Application.ActiveWorkbook.path & "\" & file)
    Dim wsSlave As Worksheet
    Dim rowSlave As Range
    Dim cellSlave As Range
    Dim hdrSlave() As Variant
    
    For Each wsSlave In wbSlave.Worksheets
        For Each rowSlave In wsSlave.Rows
            If rowSlave.Row <= 1 Then
                For Each cellSlave In rowSlave.Cells
                    If Not IsEmpty(cellSlave) Then
                        Set hdrMaster = Nothing
                        On Error Resume Next
                            Set hdrMaster = tbMaster.ListColumns(cellSlave.Text)
                        On Error GoTo 0
                        If hdrMaster Is Nothing Then
                            Set hdrMaster = tbMaster.ListColumns.Add
                            hdrMaster.Name = cellSlave.Text
                        End If
                        ReDim Preserve hdrSlave(cellSlave.Column)
                        hdrSlave(cellSlave.Column) = cellSlave.Text
                    Else
                        Exit For
                    End If
                Next cellSlave
            Else
                If Not IsEmpty(rowSlave.Cells(1)) Then
                    Set rowMaster = tbMaster.ListRows.Add
                    rowMaster.Range(tbMaster.ListColumns("File").Index) = file
                    For Each cellSlave In rowSlave.Cells
                        If Not IsEmpty(cellSlave) Then
                            rowMaster.Range(tbMaster.ListColumns(hdrSlave(cellSlave.Column)).Index) = cellSlave.Text
                        Else
                            Exit For
                        End If
                    Next cellSlave
                Else
                    Exit For
                End If
            End If
        Next rowSlave
    Next wsSlave
    
    tbMaster.Range.Columns.AutoFit
    
    wbMaster.Save
    wbSlave.Close (False)
End Sub

I am also turning off ScreenUpdating before calling the sub.

Upvotes: 1

Views: 174

Answers (1)

Tim Williams
Tim Williams

Reputation: 166256

Here's what I mean.

I've pulled out the process of appending a range onto a Table/Listobject into AddRangeintoTable - you would call that from your main code.

I have a stub method Tester as an example of how it would be called.

Note the comment at the bottom of the main code about whether or not you'll need to resize the table after adding the new content - there's a setting in Options to control that.

Sub Tester()

    AddRangeIntoTable Range("A4").CurrentRegion, _
                      ActiveSheet.ListObjects("Table2"), _
                      True

End Sub


'append a Range onto a Table/Listobject, optionally inserting
'  any columns not found in the Table
Sub AddRangeIntoTable(FromRange As Range, ToTable As ListObject, _
                        Optional AppendNewCols As Boolean = False)
    
    Dim c As Range, lc As ListColumn, data, rw, col, newData(), hdr
    Dim dictColPos, rngHdrs As Range, i As Long, numRows As Long, numCols As Long
    
    data = FromRange.Value                                'get all new data as array
    Set dictColPos = CreateObject("scripting.dictionary") 'for mapping columns
    
    'map headers and (optionally) add any necessary headers not already present
    For col = 1 To UBound(data, 2)
        hdr = data(1, col)
        Set lc = Nothing
        On Error Resume Next
        Set lc = ToTable.ListColumns(hdr)
        On Error GoTo 0
        If lc Is Nothing And AppendNewCols Then 'add mising column(s)?
            Set lc = ToTable.ListColumns.Add
            lc.Name = hdr
        End If
        If Not lc Is Nothing Then
            dictColPos(hdr) = lc.Index   'map header name to column index position
        End If
    Next col
   
    'size array for data to append to listobject and fill it
    numRows = UBound(data, 1) - 1
    numCols = ToTable.ListColumns.Count
    ReDim newData(1 To numRows, 1 To numCols)
    For rw = 2 To UBound(data, 1)
        For col = 1 To UBound(data, 2)
            If dictColPos.exists(data(1, col)) Then
                newData(rw - 1, dictColPos(data(1, col))) = data(rw, col)
            End If
        Next col
    Next rw
    
    With ToTable
        With .DataBodyRange
            .Rows(.Rows.Count).Cells(1).Offset(1, 0) _
                 .Resize(numRows, numCols).Value = newData  'add the new data
        End With
        
        '  Excel options >> Proofing >> Autocorrect options >> Autoformat as you type
        '                >> "Include new rows and columns in table"
        If Not Application.AutoCorrect.AutoExpandListRange Then
            .Resize ToTable.Range.Resize(.Range.Rows.Count + numRows)
        End If
        .Range.Columns.AutoFit
    End With
    
End Sub

Upvotes: 1

Related Questions