VBA Loop Crashing Excel

[blimbert]

Hello - I have a need to consolidate data from two worksheets in 2,700 workbooks into two worksheets in 1 big workbook. I have a piece of code that works well enough, but after a varying number of loops it crashes excel altogether. Sometimes it may make it through 10 files, others it may get through 40 or so, and all numbers in between.

I do not receive any error messages in excel and cannot track down what is causing the crash. Excel simply crashes, as if it was terminated from Task Manager.

My code is novice level at best, please accept my apologies for any incorrect structure/grammar/commenting.
I have included the sub and the function called within it to determine if a worksheet exists

Could you please review this code and see if something is causing the issue?
Thank you!

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("FileLis").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 from A2 to the end of the range
               
                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 from A2 to the end of the range
               
                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

 

[mikerickson]

One workaround would be to create a loop that every 10 files, you save the big workbook and close the unneeded files that you've opened and then do the next chunk of 10.