Save As of copied sheets is very slow

[sweeneytime]

Hi folks,

My code populates 5 sheets before making a copy for a new workbook, then save as, then email.

The save as part is very slow. I've stepped through it and it lags for 30 seconds.

Has anybody seen this before? I haven't had much luck on google.

All help appreciated!

This is the section of code:

           'Copy 5 reports to new workbook
            Sheets(Array("PL", "Orygen YTD B v A", "Forecast", "Project PL", "staff costing")).Copy
            
            Set Wb2 = ActiveWorkbook
          
            Application.DisplayAlerts = False
            Wb2.SaveAs Filename:=Path & "\" & Filename & ".xlsx"
            Application.DisplayAlerts = True

This is the entire code

Sub Data()

    Dim ProjectList As Range
    Dim ProjectCode As Range
    Dim ProjectNumber As String
    Dim LR As Integer
    Dim LR2 As Integer
    Dim Vcell As Range
    Dim Pcell As String
    Dim Path As String
    Dim Filename As String
    Dim Monthname As String
    Dim EmailAdd As String
    Dim FirstName As String
    Dim Surname As String
    Dim OutApp As Object
    Dim OutMail As Object
    Dim wb As Workbook
    Dim Wb2 As Workbook
    Dim PT As PivotTable
    Dim wb1 As Workbook
    Dim ws1 As Worksheet
    
    Dim StartTime As Double
    Dim SecondsElapsed As Double
    

    'Remember time when macro starts
    StartTime = Timer
        
        
    
    'Optimize Code
    Call OptimizeCode_Begin
    Application.ScreenUpdating = False

       
    Set wb = ActiveWorkbook
    Set wb1 = ThisWorkbook
    
    
    
    Sheets("Test Owner & Email").Select
    LR = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
    Set ProjectList = Range("A2:A" & LR)
    
    
    For Each Vcell In ProjectList

        
        'Vcell as project number
        Sheets("Test Owner & Email").Select
         Vcell.Select
        
        ProjectNumber = ActiveCell.Value
        EmailAdd = ActiveCell.Offset(0, 2).Value
        FirstName = ActiveCell.Offset(0, 3).Value
        Surname = ActiveCell.Offset(0, 4).Value
        
        
        'Pcell as porject owner
        ActiveCell.Offset(0, 1).Select
        Pcell = ActiveCell.Value
        
        Vcell.Copy
        
        'Clear data sheet
        Sheets("Orygen YTD B V A").Select
        ActiveSheet.UsedRange.Select
        Selection.Delete
        
        
        'Filter & Copy Orygen YTD Bud vs Act
        Sheets("Orygen YTD Bud vs Act").Select
        LR2 = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row

        Range("A4:AL" & LR2).Select
        Selection.AutoFilter
        Selection.AutoFilter Field:=3, Criteria1:=Vcell

        'Copy to data dump tab
        Range("A1:AL" & LR2).Copy
        Sheets("Orygen YTD B V A").Select
       
        
        Range("A1").PasteSpecial xlPasteValues
        Range("A1").PasteSpecial xlPasteFormats
        Range("A1").Select
        
            'Filter & Copy Orygen Forecast
            
            'Clear data sheet
            Sheets("Forecast").Select
            ActiveSheet.UsedRange.Select
            Selection.Delete
            
            
            Sheets("Orygen Forecast").Select
            LR2 = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
            
            Range("A4:AL" & LR2).Select
            Selection.AutoFilter
            Selection.AutoFilter Field:=3, Criteria1:=Vcell
    
            'Copy to data dump tab
            Range("A1:AL" & LR2).Copy
            Sheets("Forecast").Select
         
        
            Range("A1").PasteSpecial xlPasteValues
            Range("A1").PasteSpecial xlPasteFormats
            Range("A1").Select
            
            
                Sheets("P&L - New Connection").Select
                ActiveSheet.ListObjects("Table_ExternalData_1").Range.AutoFilter Field:=12, _
                    Criteria1:=Vcell
                    
                Range("Table_ExternalData_1[#All]").Select
                Selection.Copy
                Sheets("PL").Select
                Range("A1").Select
                Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                    :=False, Transpose:=False
                  
'
'                Sheets("Staff Costing").Select
'                 Set PT = ActiveSheet.PivotTables("PivotTable2")
'                PT.Update
'
'                Sheets("Project PL").Select
'                 Set PT = ActiveSheet.PivotTables("PivotTable1")
'                PT.Update
'
'

            'File Name
            Monthname = Sheets("Macro Controls").Range("A13")
            Filename = ProjectNumber + "-" + Pcell
            
            
            'File Location
            Path = Sheets("Macro Controls").Range("A17")
            
            
            
            'Copy 5 reports to new workbook
            Sheets(Array("PL", "Orygen YTD B v A", "Forecast", "Project PL", "staff costing")).Copy
            
            Set Wb2 = ActiveWorkbook
          
            Application.DisplayAlerts = False
            Wb2.SaveAs Filename:=Path & "\" & Filename & ".xlsx"
            Application.DisplayAlerts = True
            
            
           
                        
                        
            'Send Email
             Set OutApp = CreateObject("Outlook.Application")
             Set OutMail = OutApp.CreateItem(0)


            EmailBody = "Dear " & FirstName & "," & vbCrLf & vbCrLf & _
            "Please find attached the " & Monthname & " report for your portfolio." & vbCrLf & vbCrLf & _
            "The report is comprehensive and provides snapshot information of Financial and HR data as at the end " & ReportDate & ". " & vbCrLf & _
            "Please review your reports every month and contact your Grants & Contracts consultant for any financial advice on Project income/expenditure balances."

           Application.DisplayAlerts = False

            On Error Resume Next
            With OutMail
                .To = EmailAdd
                .CC = ""
                .BCC = ""
                .Subject = "Test"
                .Body = EmailBody
                .Attachments.Add ActiveWorkbook.FullName
             '' .Send
                .Display
                Application.Wait (Now + TimeValue("0:00:02"))
                Application.SendKeys "%s"

            End With
        On Error GoTo 0

            Application.DisplayAlerts = True

        Set OutMail = Nothing
        Set OutApp = Nothing
                            
                    
        
       Wb2.Close SaveChanges:=False
        wb.Activate
                
                
        'End With


    Next Vcell

    
    
    
    'Optimize Code
    Call OptimizeCode_End
    Application.ScreenUpdating = True
    
        
        
    'Determine how many seconds code took to run
     SecondsElapsed = Round(Timer - StartTime, 2)

    'Notify user in seconds
     MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation


End Sub

 

[Michael M]

Is the path correct ?
Is the path on a server ?
Are you sure it is the save component ?
If so, try saving to the desktop and see if that speeds things up

Also, There are a lot of Select. Selections involved in your code which will slow it down

 

[sweeneytime]

Thanks for the reply.

Yes the path is correct.

It is on a server.

Saving to desktop made it slower by 15 seconds! haha

I used the code stand alone and it works fine.

I think its the save component as I step through the rest of code quickly, then it lags on that line of code.

Any other suggestions?


Yes, lots selects etc, my coding is rusty! but with out the save as lag it runs under 2 seconds, so I'll make that more efficient later,

 

[sweeneytime]

I solved it by turning off calculation before saving.

I stepped through the macro, then went to manually save, then I saw it was the calculation that was holding things up.

Appreciate the help.

 

[Michael M]

Glad you got it sorted...