VBA - How do I speed this code up?

[Melissa82]

I am extremelly new to VBA but relatively competant at googling and figuring it out.

I have manage to put this code together for a file I run constantly but it is fairly slow. I know I am not doing things in the best way but if anyone has some ideas for speeding some of the more repetative actions up I would appreciate it!

Sub UpdateDD()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim fd As FileDialog, lRow As Long, vSelectedItem As Variant, srcWB As Workbook, desWB As Workbook, ws As Worksheet, FileName As Variant
Set desWB = ThisWorkbook
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.AllowMultiSelect = True
If .Show = -1 Then
For Each vSelectedItem In .SelectedItems
Set srcWB = Workbooks.Open(vSelectedItem)
Sheets.Copy after:=desWB.Sheets(desWB.Sheets.Count)
srcWB.Close False
Next
Else
End If
End With
On Error Resume Next
For Each ws In ActiveWorkbook.Worksheets
If ws.Name Like "Pace Demand*" Then
ws.Select
ActiveSheet.Name = "Demand"
Exit For
End If
Next ws
Worksheets("Redemption Rooms on the Books R").Cells.Copy Worksheets("Redemptions").Cells
Worksheets("Pick Up Report - Business Type").Cells.Copy Worksheets("Group Pickup").Cells
Worksheets("Pick Up Report - Business View").Cells.Copy Worksheets("Segments").Cells
Worksheets("Property (2)").Cells.Copy Worksheets("Property").Cells
Worksheets("Current").Cells.Copy Worksheets("TMTP").Cells
Worksheets("Demand").Cells.Copy Worksheets("Pace").Cells
Sheets("Pick Up Report - Business Type").Delete
Sheets("Pick Up Report - Business View").Delete
Sheets("Redemption Rooms on the Books R").Delete
Sheets("Property (2)").Delete
Sheets("Summary").Delete
Sheets("Previous").Delete
Sheets("Current").Delete
Sheets("Demand").Delete
Sheets("Top SRPs by MCAT").Delete
Sheets("Top Accounts Summary").Delete
For Each ws In ActiveWorkbook.Worksheets
If ws.Name Like "Page*" Then
ws.Select
ActiveSheet.Name = Range("A1")
End If
Next ws
Sheets("Property").Visible = False
Sheets("Segments").Visible = False
Sheets("Group Pickup").Visible = False
Sheets("Pace").Visible = False
Sheets("TMTP").Visible = False
Sheets("Redemptions").Visible = False
ActiveWorkbook.RefreshAll
Sheets("Daily Detail").Select
Range("B12").Select
Application.DisplayAlerts = True
Application.ScreenUpdating = True
ThisFile = Sheets("Daily Detail").Range("B3") & " Daily Detail " & Format(Date, "mm.dd.yyyy") & ".xlsm"
FileName = Application.GetSaveAsFilename(ThisFile, _
"Excel files,*.xlsm", 1, "Select your folder and filename")
If TypeName(FileName) = "Boolean" Then Exit Sub
ActiveWorkbook.SaveAs FileName
End Sub

 

[offthelip]

Why are you copying entire worksheets and then deleting the source sheet?? Why not just rename the source sheet which will be much faster
like this:

Worksheets("Redemption Rooms on the Books R").Name = "Redemptions"

 

[Alex Blakenburg]

I am assuming that you have formulas and/or queries pointing to the original sheets so that renaming the sheets is not an option.

I don't have any data with which to test it but see if this works for you and if it runs any faster.
@offthelip and I are trying to get rid of having to copying the sheets twice.

I have assumed the additional sheets deleted weren't in the main workbook but copied across in the All Sheets copy. Uncomment any sheet deletions for which this is not the case.

Also I have skipped some steps from Demand Pace* > Demand > Pace, so just check that it does what you need.

Sub UpdateDD_Mod()
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    Dim fd As FileDialog, lRow As Long, vSelectedItem As Variant, srcWB As Workbook, desWB As Workbook, ws As Worksheet, FileName As Variant
    Set desWB = ThisWorkbook
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
    With fd
        .AllowMultiSelect = True
        If .Show = -1 Then
            For Each vSelectedItem In .SelectedItems
                Set srcWB = Workbooks.Open(vSelectedItem)
                For Each ws In srcWB.Sheets
                    Select Case ws.Name
                        Case "Redemption Rooms on the Books R"
                            ws.Cells.Copy desWB.Worksheets("Redemptions").Cells
                        Case "Pick Up Report - Business Type"
                            ws.Cells.Copy desWB.Worksheets("Group Pickup").Cells
                        Case "Pick Up Report - Business View"
                            ws.Cells.Copy desWB.Worksheets("Segments").Cells
                        Case "Property (2)"
                            ws.Cells.Copy desWB.Worksheets("Property").Cells
                        Case "Current"
                            ws.Cells.Copy desWB.Worksheets("TMTP").Cells
                        Case Else
                            If ws.Name Like "Pace Demand*" Then
                                ws.Cells.Copy desWB.Worksheets("Pace").Cells
                            End If
                    End Select
                Next ws
                srcWB.Close False
            Next
        Else
        End If
    End With
    On Error Resume Next
    
'    XXX Assumed these were copied in with the All Sheets copy and deemed not required
'    XXX Uncomment any for which this is not the case
'    Sheets("Summary").Delete
'    Sheets("Previous").Delete
'    Sheets("Top SRPs by MCAT").Delete
'    Sheets("Top Accounts Summary").Delete
    
    For Each ws In ActiveWorkbook.Worksheets
        If ws.Name Like "Page*" Then
            ws.Select
            ActiveSheet.Name = Range("A1")
        End If
    Next ws
    
    Sheets("Property").Visible = False
    Sheets("Segments").Visible = False
    Sheets("Group Pickup").Visible = False
    Sheets("Pace").Visible = False
    Sheets("TMTP").Visible = False
    Sheets("Redemptions").Visible = False
    
    ActiveWorkbook.RefreshAll
    Sheets("Daily Detail").Select
    Range("B12").Select
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    
    Dim ThisFile As String
    ThisFile = Sheets("Daily Detail").Range("B3") & " Daily Detail " & Format(Date, "mm.dd.yyyy") & ".xlsm"
    FileName = Application.GetSaveAsFilename(ThisFile, _
                             "Excel files,*.xlsm", 1, "Select your folder and filename")
    If TypeName(FileName) = "Boolean" Then Exit Sub
    ActiveWorkbook.SaveAs FileName
End Sub

 

[Melissa82]

I am assuming that you have formulas and/or queries pointing to the original sheets so that renaming the sheets is not an option.

I don't have any data with which to test it but see if this works for you and if it runs any faster.
@offthelip and I are trying to get rid of having to copying the sheets twice.

I have assumed the additional sheets deleted weren't in the main workbook but copied across in the All Sheets copy. Uncomment any sheet deletions for which this is not the case.

Also I have skipped some steps from Demand Pace* > Demand > Pace, so just check that it does what you need.

Your assumption is correct, all of the data is coming in from a bunch of different reports but need to copy into the master tabs because the main sheet compiles it into one report. Trying to keep the main sheet simple and the formulas clean.

The only issue I have is if I am importing any extra files/sheets other than the ones I am copying into the master. Previously they would typically copy to a new sheet named after whatever is in A1 of the sheet (except 'Previous" and "Summary" which were extra sheets in the same file as "Current". Would I have to do a seperate selection for those reports of is there a way to select them all as one?

Thank you for the help!

 

[Alex Blakenburg]

I would need a more concrete example of what you want the code to do, if you need the code modified.
Under “case else” you can copy any other sheets that don’t need to be copied into an existing sheet.
The select-case statements are only there because there is a specific “from and to” parameter for each of those sheet names.