Speeding up VBA

[jvoss]

Good day. i did this code from Merge cells from all or some worksheets into one Master sheet and a few changes from Consolidating Data from Multiple Worksheets into a Summary Worksheet in Excel. it works good but i have a time issue. it takes 5+min to run the code. there has to be a faster code(or better code) that can do the same.

here is my code and a lot of notes.. and yes i have some post consolidating work being done.

basically it takes columns A2 to L??? (end of data), from each worksheet. it skips any worksheet that is in the 'exclude sheet list. right now there are 15 sheets the data is being consolidated but may have more added later. the total number of worksheet in the workbook is 51

'When you run one of the examples it will first delete the summary worksheet
'named RDBMergeSheet if it exists and then adds a new one to the workbook.
'This ensures that the data is always up to date after you run the code.
'https://jkp-ads.com/rdb/win/s3/win002.htm
'*****READ THE TIPS on the website****


Sub CopyDataWithoutHeaders()
    Dim Sh As Worksheet
    Dim ws As Variant
    Dim DestSh As Worksheet
    Dim Last As Long
    Dim LastC As Long
    Dim shLast As Long
    Dim shLastC As Long
    Dim CopyRng As Range
    Dim StartRow As Long

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlAutomatic
        .DisplayAlerts = False
    End With

    'Delete the sheet "RDBMergeSheet" if it exist
        'On Error Resume Next
        ActiveWorkbook.Worksheets("Data").Activate      '.Delete
    'REMOVE IF USING DELETE
        Cells.ClearContents
        'Columns("A:Q").Select
        'Selection.Clear 'Contents
        'On Error GoTo 0


    'Add a worksheet with the name "RDBMergeSheet"
    'On Error Resume Next
    'Set DestSh = ActiveWorkbook.Worksheets.Add
    'Set DestSh = Worksheets("RDBMergeSheet")
    'DestSh.Name = "RDBMergeSheet"
    'On Error GoTo 0
    
    'Destation worksheet
    Set DestSh = Worksheets("Data")
    ActiveSheet.UsedRange
    'Fill in the start row
    StartRow = 2

    'loop through all worksheets and copy the data to the DestSh
    'For Each sh In ActiveWorkbook.Worksheets
    'exclude sheet
        For Each Sh In Sheets '(Array("ASI"))
        Select Case Sh.Name
        Case Is = "NewData", "Value_PAL", "Value_USA", _
              "Value_JPN", "Data_G", "Data_I", _
              "Report", "Missing", "Incoming", _
              "Value", "Image", "Stats", _
              "Data", "Search", "NTI", _
              "Extra", "Tetris_List_GB", "Trade", _
              "WebSites_data", "Negotiations"


        'No Code here if excluded
        Case Else

        'Loop through all worksheets except the RDBMerge worksheet and the
        'Information worksheet, you can ad more sheets to the array if you want.
        If IsError(Application.Match(Sh.Name, _
                Array(DestSh.Name, "Data"), 0)) Then

            'Find the last row with data on the DestSh and sh
            
            Last = lastrow(DestSh)
            LastC = LastCol(DestSh)
            
            shLast = lastrow(Sh)
            shLastC = LastCol(Sh)
        
        'MsgBox sh.Name & "  " & shLast & ":" & shLastC
        
            If Sh.FilterMode Then  'sh.AutoFilterMode Or
               Sh.ShowAllData
            End If
        
            'If sh is not empty and if the last row >= StartRow copy the CopyRng
            If shLast > 0 And shLast >= StartRow Then

                'Set the range that you want to copy
    
                Set CopyRng = Sh.Range("A" & StartRow & ":l" & shLast) '(sh.Rows(StartRow), sh.Rows(shLast))
'MsgBox CopyRng
                '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 below example 1 on this page
                CopyRng.Copy
'MsgBox sh.Name
                With DestSh.Cells(Last + 1, "A")
                    .PasteSpecial xlPasteValues
                    .PasteSpecial xlPasteFormats
                    Application.CutCopyMode = False
                End With

            End If

        End If
    'Next
    End Select
Next Sh

ExitTheSub:

    
    Application.GoTo DestSh.Cells(1)

    'AutoFit the column width in the DestSh sheet
    DestSh.Columns.AutoFit
ActiveSheet.UsedRange
'''''''''''''''''''''''''''''''''''''''''''''''''
' Add Data Sheet
'''''''''''''''''''''''''''''''''''''''''''''''''
    Call DataSetup
    
    
End Sub

 

[jolivanes]

Apparently your code is not performing the way you think it should.
Instead of possible helpers having to decipher your code before they can even start attempting to get a macro to do what MIGHT be the result of taking your code apart, maybe you can help by explaining in a complete and concise manner what you would like to achieve.
FYI, there are many roads leading to Rome and the same goes for code. There are many ways to get a result.

 

[Zot]

I thought to speed up VBA the Application.Calculation is set to xlManual

 

[jvoss]

I thought to speed up VBA the Application.Calculation is set to xlManual

hummm i'll try. but dose an automatic calculation invoke with a past? dose that cause that whole workbook to recalculate?

 

[jvoss]

Apparently your code is not performing the way you think it should.
Instead of possible helpers having to decipher your code before they can even start attempting to get a macro to do what MIGHT be the result of taking your code apart, maybe you can help by explaining in a complete and concise manner what you would like to achieve.
FYI, there are many roads leading to Rome and the same goes for code. There are many ways to get a result.

thanks for only reading what you want and not what is posted. ill look for more helpful and concise responses.

 

[Zot]

hummm i'll try. but dose an automatic calculation invoke with a past? dose that cause that whole workbook to recalculate?

It will give the calculated results but it will be faster this way.

 

[jvoss]

I thought to speed up VBA the Application.Calculation is set to xlManual

that cut the time down to 2.5 min..

 

[jvoss]

It will give the calculated results but it will be faster this way.

how do i do a full workbook calculation vba. ie.. do i do a recalculation on each sheet (51 sheets)