VBA Loop Crashing Excel-CodePudding

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("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

CodePudding user response：

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