Excel freezing when importing many rows - excel

Question

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.

Answer 1

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