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

 

[j0nthn]

Runtime error 9: subscript out of range for:

  .Offset(, 6).Resize(UBound(arr, 1)).Value = wks.Name

 

[JackDanIce]

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 wks In ThisWorkbook.Worksheets
    
        Select Case wks.Name
            'Ignore sheets with these names
            Case "Setup instructions", "How to use", "DATA", "Input"
                
            Case Else
            
                arr = wks.Range("E2:J5001").Value
                With wksDest
                    LR = .Cells(.Rows.Count, 1).End(xlUp).Row
                    If LR + UBound(arr, 1) <= wksDest.Rows.Count Then
                        With .Cells(LR + 1, 1)
                            .Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
                            .Offset(, 6).Resize(UBound(arr, 1)).Value = wks.Name
                            .Offset(, 7).Resize(UBound(arr, 1)).wks.Range("B5").Value
                            .Offset(, 8).Resize(UBound(arr, 1)).wks.Range("B6").Value
                            Erase arr
                        End With
                    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 With
                
        End Select
    
    Next wks
    
    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 = DateAdd("dd", 1, rng.Value)
            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]

Run-time error 438: Object doesn't support this property or method:

.Offset(, 7).Resize(UBound(arr, 1)).wks.Range("B5").Value

 

[j0nthn]

Also, when running the code, this line apparently added only the first sheet name ("Data1") after every row, instead of the sheet names the data was taken from

.Offset(, 6).Resize(UBound(arr, 1)).Value = wks.Name

 

[JackDanIce]

Change to

.Offset(, 7).Resize(Ubound(Arr, 1)).Value = wks.Range("B5").Value
.Offset(, 8).Resize(Ubound(Arr, 1)).Value = wks.Range("B6").Value

 

[j0nthn]

That did the trick! Super grateful for your help JackDanIce, it's people like you, going out of their way to help a stranger on the internet, who make the world a better place. I just gave you a 'Like', but let me know if you have some kind of 'buy me a coffee link'

 

[JackDanIce]

You're very welcome. I learnt loads when I first started learning VBA with the aid of this board (+ book and internet searching), happy to offer help back in return, so glad it's working for you!