Macro run time exponentially increases when run several times in a row/in loop

[j0nthn]

When I try to run below code in a loop, or several times in a row (i.e. Call RunAllMergeSheets, Call RunAllMergeSheets etc) the time it takes to run the macro increases exponentially.
- Is there any way to speed this up? What's causing the biggest slowdown in the speed (minus the increase in file-size)

Many thanks for your help

Sub RunAllMergeSheets()    
    Dim sh As Worksheet
    Dim DestSh As Worksheet
    Dim Last As Long
    Dim CopyRng As Range


    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With


    'Set Dest to worksheet "ALL"
    Set DestSh = ActiveWorkbook.Worksheets("ALL")
    DestSh.Name = "ALL"


    'loop through all worksheets and copy the data to the DestSh
    For Each sh In ActiveWorkbook.Worksheets
        If IsError(Application.Match(sh.Name, _
    Array(DestSh.Name, "Setup instructions", "How to use", "DATA", "INPUT"), 0)) Then


            'Find the last row with data on the DestSh
            Last = LastRow(DestSh)


            'Fill in the range that you want to copy
            Set CopyRng = sh.Range("E2:J5001")
            
            'Test if there enough rows in the DestSh to copy all the data
            If Last + CopyRng.Rows.Count > DestSh.Rows.Count Then
                MsgBox "There are not enough rows in the Destsh"
                GoTo ExitTheSub
            End If


            'This example copies values/formats, if you only want to copy the
            'values or want to copy everything look at the example below this macro
            With CopyRng
            DestSh.Cells(Last + 1, "A").Resize(.Rows.Count, _
            .Columns.Count).Value = .Value
            End With


            'Optional: This will copy the sheet name + time stamps in the respective columns
            DestSh.Cells(Last + 1, "G").Resize(CopyRng.Rows.Count).Value = sh.Name
            DestSh.Cells(Last + 1, "H").Resize(CopyRng.Rows.Count).Value = sh.Range("B5")
            DestSh.Cells(Last + 1, "I").Resize(CopyRng.Rows.Count).Value = sh.Range("B6")


        End If
    Next


ExitTheSub:


    Application.Goto DestSh.Cells(1)
    
    'Delete empty rows
    On Error Resume Next
    Columns("A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    
    'Add one to start + end dates
    Dim r As Range
    
    Sheets("INPUT").Select


    Set r = Range("B2:B3")


    For Each cell In r
        If IsDate(cell.Value) Then
            If cell.Value > 0 Then
                cell.Value = cell.Value + 1
            End If
        Else
            MsgBox "Cell " & cell.Address(0, 0) & "is not a date"
            Exit Sub
        End If
    Next


End Sub




Function LastRow(sh As Worksheet)
    On Error Resume Next
    LastRow = sh.Cells.Find(What:="*", _
                            After:=sh.Range("A1"), _
                            Lookat:=xlPart, _
                            LookIn:=xlFormulas, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Row
    On Error GoTo 0
End Function

 

[JackDanIce]

Welcome to the board. This may be quicker, try:

  Sub MergeSheets()
 
    Dim wks     As Worksheet
    Dim wksDest As Worksheet
    Dim var     As Variant
    Dim arr()   As Variant
    Dim rng     As Range
    
    Dim LR      As Long
    
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With
    
    Set wksDest = Sheets("All")
    
    For Each var In Array("Setup instructions", "How to use", "DATA", "Input")
    
        On Error Resume Next
        Set wks = Sheets(str(var))
        On Error GoTo 0
        
        If Not wks Is Nothing Then
            LR = wksDest.Cells(rows.count, 1).End(xlUp).row
            arr = wks.Range("E2:J5001")
            
            If LR + UBound(arr, 1) <= wksDest.rows.count Then
                With wksDest.Cells(LR + 1, 1)
                    .Resize(UBound(arr, 1), UBound(arr, 2)).value = arr
                    .Offset(, 6).value = wks.Name
                    .Offset(, 7).Resize(, 2).value = wks.Range("B5").Resize(, 2).value
                End With
                Erase arr
            Else
                Erase arr
                MsgBox "Not enough rows in " & wksDest.Name & " sheet to merge further data", vbOKOnly, "Excess number of rows required"
                Exit For
            End If
        End If
        
    Next var
    
    On Error Resume Next
    wksDest.Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    On Error GoTo 0
    
    With Sheets("INPUT")
        For Each rng In .Range("B2:B3")
            If IsDate(rng.value) Then
                rng.value = rng.value = 1
            Else
                MsgBox "Cell " & rng.Address(0, 0) & " is not a date", vbExclamation, "Cell not a date"
            End If
        Next rng
        .Select
    End With
    

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
    End With
    
    Set wksDest = Nothing
    
 End Sub

 

[j0nthn]

Thanks Jack, appreciate the help, and I see there are a lot of optimizations made, but for some reason my Excel crashes when trying to run your script..
Any ideas?
Best
Jon

 

[JackDanIce]

Excel itself crashes or the code errors?

If the later, can you post the error message and what line it occurs on.

If the former, difficult to suggest, could be an external problem with your PC, that the code may trigger (eg insufficient resources).

 

[j0nthn]

It's the former one: "Microsoft Excel has crashed and is trying to restart itself"

I have a pretty decent laptop (Lenovo Y410P, 16gb Ram, i7 quad core processor)

Does it work fine for you?

 

[j0nthn]

I believe the error stems from somewhere in this part of the code:

If Not wks Is Nothing Then            LR = wksDest.Cells(Rows.Count, 1).End(xlUp).Row
            arr = wks.Range("E2:J5001")
            
            If LR + UBound(arr, 1) <= wksDest.Rows.Count Then
                With wksDest.Cells(LR + 1, 1)
                    .Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
                    .Offset(, 6).Value = wks.Name
                    .Offset(, 7).Resize(, 2).Value = wks.Range("B5").Resize(, 2).Value
                End With
                Erase arr
            Else
                Erase arr
                MsgBox "Not enough rows in " & wksDest.Name
                Exit For
            End If
        End If
        
    Next var

 

[JackDanIce]

Without your spreadsheet, I can't test it to see if I experience the same problem.

Maybe try pressing F8 and step through each line of code, see if that works (or not)?

 

[j0nthn]

Thanks Jack,

Unfortunately I cannot share my exact file with you as it contains private data..

When pressing F8 and stepping through each line of code, I find that my excel breaks here:

Set wks = Sheets(str(var))
On Error GoTo 0

 

[j0nthn]

Correction, specifically this line:

[COLOR=#333333]Set wks = Sheets(str(var))[/COLOR]

 

[JackDanIce]

Does it work fine for you?

Not sure how I can answer this then, without the spreadsheet, private data or otherwise!

If the error is on that line, check the value of var and see if it exactly matches the worksheet name, I guess it's erroring because the var value from the array is not an exact match so it can't find that sheet object.