How to consolidate data from two worksheets in 2,700 workbooks into two worksheets?

Question

I need to consolidate data from two worksheets in 2,700 workbooks into two worksheets in one workbook.

I have code that works well enough, but after a varying number of loops it crashes Excel.

It makes it through anywhere from 10 files up to 40 or so.

I do not receive any error messages in Excel. Excel simply crashes, as if it was terminated from Task Manager.

I included the sub and the function called within it to determine if a worksheet exists.

Sub SheetCopier()
Dim wb As Workbook
Dim tbl As ListObject
Dim CurrentFile As Variant
Dim LoadRows As Double
Dim AuditRows As Double

Application.ScreenUpdating = False
Application.DisplayAlerts = False

Path = "C:\Desktop\FileList\"

Set tbl = Worksheets("FileList").ListObjects("FileList")   'table spring all of the files to loop through

counter = 2    'starts the counter so the file list can be updated for progress

For Each CurrentFile In tbl.ListColumns("Name").DataBodyRange
    LoadRows = 0
    AuditRows = 0
    
    Set wb = Application.Workbooks.Open(Filename:=Path & CurrentFile, UpdateLinks:=False)  'opens the data file
        
    'Copies data from the LOAD sheet
    If SheetExists(wb, "LOAD") Then  'calls the SheetExists function to determine if the sheet exists
        wb.Sheets("LOAD").Select
        Range("A1").Select
            
        If Range("A1").Value <> "" And Range("A2").Value <> "" Then 'if there is actual information in the load sheet
            Range(Range("A2"), Range("A2").SpecialCells(xlLastCell)).Select 'select all cells in the load sheet except for the header row
            LoadRows = Selection.Rows.Count 'count how many rows there are
            Range("S2:S" & LoadRows + 1).Value = CurrentFile 'appends the filename to the rows that are being copied
            Range(Range("A2"), Range("A2").SpecialCells(xlLastCell)).Copy 'copy the rows
                
            ThisWorkbook.Activate 'come back to the main workbook
                
            Sheets("LOAD").Select 'go to the LOAD sheet in the main workbook
            Range("A1").Select 'go to this workbooks load sheet
            Cells(Range("A2").SpecialCells(xlLastCell).Row + 1, 1).Select 'go to the last row on the load sheet
            ActiveSheet.Paste 'paste the data
            tbl.Range.Cells(counter, 3) = LoadRows 'mark the number of rows copied on the file list
        End If
    End If
        
    wb.Activate 'go back to the target file to copy from
        
    'Copeis data from the AUDIT RESULTS sheet
    If SheetExists(wb, "AUDIT RESULTS") = True Then
        wb.Sheets("AUDIT RESULTS").Select
        Range("A1").Select
            
        If Range("A1").Value <> "" And Range("A2").Value <> "" Then 'if there is actual information in the audit sheet
            Range(Range("A2"), Range("A2").SpecialCells(xlLastCell)).Select 'select all cells in the load sheet
            AuditRows = Selection.Rows.Count 'count how many rows there are
            Range("AA2:AA" & AuditRows + 1).Value = CurrentFile 'appends the filename to the rows that are being copied
            Range(Range("A2"), Range("A2").SpecialCells(xlLastCell)).Copy 'copy the rows
                
            ThisWorkbook.Activate 'come back to this workbook
                
            Sheets("AUDIT RESULTS").Select
            Range("A1").Select 'go to this workbooks load sheet
            Cells(Range("A2").SpecialCells(xlLastCell).Row + 1, 1).Select 'go to the last row on the load sheet
            ActiveSheet.Paste 'paste the data
            tbl.Range.Cells(counter, 4) = AuditRows 'mark the number of rows copied
        End If
    End If
    
    wb.Close SaveChanges:=False  'close the target file
    
    Set wb = Nothing
    
    If counter Mod 10 = 0 Then ThisWorkbook.Save 'save the main file every 10 loops (because of the crashes)
    
    counter = counter + 1
    
Next

Set tbl = Nothing

Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub


Function SheetExists(wb As Workbook, strSheetName As String) As Boolean

Dim wks As Worksheet

For Each wks In wb.Worksheets
    If wks.Name = strSheetName Then
        SheetExists = True
        Exit Function
    End If
Next

SheetExists = False

End Function

Tried changing various aspects of the loops, same result.

Answer 1

Avoiding Active/Select, and refactoring out the common code to a separate function:

Sub SheetCopier()
    Const FILE_PATH As String = "C:\Desktop\FileList\" 'use const for fixed values
    
    Dim wb As Workbook, tbl As ListObject
    Dim CurrentFile As Range, wsLoad As Worksheet, wsAudit As Worksheet
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    Set wsLoad = ThisWorkbook.Worksheets("LOAD")
    Set wsAudit = ThisWorkbook.Worksheets("AUDIT RESULTS")
    
    Set tbl = ThisWorkbook.Worksheets("FileList").ListObjects("FileList")
    For Each CurrentFile In tbl.ListColumns("Name").DataBodyRange.Cells
        
        Set wb = Application.Workbooks.Open(Filename:=FILE_PATH & CurrentFile.Value, _
                                            ReadOnly:=True, UpdateLinks:=False)
        
        tbl.Range.Cells(CurrentFile.Row, 3) = CopyData(wb, "LOAD", "S", _
               wsLoad.Range("A2").SpecialCells(xlLastCell).EntireRow.Columns("A").Offset(1))
         
        tbl.Range.Cells(CurrentFile.Row, 4) = CopyData(wb, "AUDIT RESULTS", "AA", _
               wsAudit.Range("A2").SpecialCells(xlLastCell).EntireRow.Columns("A").Offset(1))
        
        wb.Close SaveChanges:=False
        
        If CurrentFile.Row Mod 10 = 0 Then ThisWorkbook.Save
    Next
    
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

'Copy data from worksheet `srcWsName` in workbook `srcWb` (if it exists) to cell `destCell`
'  Insert the source workbook filename in the column `fNameCol` before copying
Function CopyData(srcWB As Workbook, srcWsName As String, _
                  fNameCol As String, destCell As Range) As Long
    Dim ws As Worksheet, rngCopy As Range
    
    On Error Resume Next 'ignore error if sheet doesn't exist
    Set ws = srcWB.Worksheets(srcWsName)
    On Error GoTo 0      'stop ignoring errors
    
    If Not ws Is Nothing Then
        If Application.CountA(ws.Range("A1:A2")) = 2 Then
            With ws.Range("A2", ws.Range("A2").SpecialCells(xlLastCell))
                CopyData = .Rows.Count     'return # of rows copied
                .EntireRow.Columns(fNameCol).Value = srcWB.Name 'fill in the file name
                .Copy destCell 'copy the data
            End With
        End If
    End If
End Function