Macro takes a long time to run

A

ajc623

Board Regular
Joined
Nov 8, 2013
Messages
57
We have a file that runs a macro that prints several sheets, moves/renames/archives sheets, and deletes data that is taking a long time complete. This macro has been put together through help from this board as well as recording several steps and inserting in the current macro. Figuring out what is causing this is beyond my skill level but I am hoping someone might be willing to take a look. Happy to provide any info or send the file. Thanks
 

Excel Facts

Last used cell?
Press Ctrl+End to move to what Excel thinks is the last used cell.
Sort by date Sort by votes
To begin, you must put here the macro and a representative example of your data using the XL2BB tool minisheet.
 
Upvote 0
Here it is, thanks

VBA Code: 
Sub DailyPrint()
'
' DailyPrint Macro
'
' Keyboard Shortcut: Ctrl+Shift+P
'
    
    Application.PrintCommunication = False
    With ActiveSheet.PageSetup
        .PrintTitleRows = ""
        .PrintTitleColumns = ""
    End With
    Application.PrintCommunication = True
    ActiveSheet.PageSetup.PrintArea = "$A$1:$L$47"
    Application.PrintCommunication = False
    With ActiveSheet.PageSetup
        .LeftHeader = ""
        .CenterHeader = ""
        .RightHeader = ""
        .LeftFooter = ""
        .CenterFooter = ""
        .RightFooter = ""
        .LeftMargin = Application.InchesToPoints(0.25)
        .RightMargin = Application.InchesToPoints(0.25)
        .TopMargin = Application.InchesToPoints(0.25)
        .BottomMargin = Application.InchesToPoints(0.25)
        .HeaderMargin = Application.InchesToPoints(0.3)
        .FooterMargin = Application.InchesToPoints(0.3)
        .PrintHeadings = False
        .PrintGridlines = False
        .PrintComments = xlPrintNoComments
        .PrintQuality = 600
        .CenterHorizontally = True
        .CenterVertically = True
        .Orientation = xlLandscape
        .Draft = False
        .PaperSize = xlPaperLetter
        .FirstPageNumber = xlAutomatic
        .Order = xlDownThenOver
        .BlackAndWhite = False
        .Zoom = 55
        .PrintErrors = xlPrintErrorsDisplayed
        .OddAndEvenPagesHeaderFooter = False
        .DifferentFirstPageHeaderFooter = False
        .ScaleWithDocHeaderFooter = True
        .AlignMarginsHeaderFooter = True
        .EvenPage.LeftHeader.Text = ""
        .EvenPage.CenterHeader.Text = ""
        .EvenPage.RightHeader.Text = ""
        .EvenPage.LeftFooter.Text = ""
        .EvenPage.CenterFooter.Text = ""
        .EvenPage.RightFooter.Text = ""
        .FirstPage.LeftHeader.Text = ""
        .FirstPage.CenterHeader.Text = ""
        .FirstPage.RightHeader.Text = ""
        .FirstPage.LeftFooter.Text = ""
        .FirstPage.CenterFooter.Text = ""
        .FirstPage.RightFooter.Text = ""
    End With
    Application.PrintCommunication = False
    ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, _
        IgnorePrintAreas:=False
    Application.PrintCommunication = False
    With ActiveSheet.PageSetup
        .PrintTitleRows = ""
        .PrintTitleColumns = ""
    End With
    Application.PrintCommunication = False
    ActiveSheet.PageSetup.PrintArea = "$A$1:$M$47"
    Application.PrintCommunication = False
    With ActiveSheet.PageSetup
        .LeftHeader = ""
        .CenterHeader = ""
        .RightHeader = ""
        .LeftFooter = ""
        .CenterFooter = ""
        .RightFooter = ""
        .LeftMargin = Application.InchesToPoints(0.25)
        .RightMargin = Application.InchesToPoints(0.25)
        .TopMargin = Application.InchesToPoints(0.25)
        .BottomMargin = Application.InchesToPoints(0.25)
        .HeaderMargin = Application.InchesToPoints(0.3)
        .FooterMargin = Application.InchesToPoints(0.3)
        .PrintHeadings = False
        .PrintGridlines = False
        .PrintComments = xlPrintNoComments
        .PrintQuality = 600
        .CenterHorizontally = True
        .CenterVertically = True
        .Orientation = xlLandscape
        .Draft = False
        .PaperSize = xlPaperLetter
        .FirstPageNumber = xlAutomatic
        .Order = xlDownThenOver
        .BlackAndWhite = False
        .Zoom = False
        .FitToPagesWide = 1
        .FitToPagesTall = 1
        .PrintErrors = xlPrintErrorsDisplayed
        .OddAndEvenPagesHeaderFooter = False
        .DifferentFirstPageHeaderFooter = False
        .ScaleWithDocHeaderFooter = True
        .AlignMarginsHeaderFooter = True
        .EvenPage.LeftHeader.Text = ""
        .EvenPage.CenterHeader.Text = ""
        .EvenPage.RightHeader.Text = ""
        .EvenPage.LeftFooter.Text = ""
        .EvenPage.CenterFooter.Text = ""
        .EvenPage.RightFooter.Text = ""
        .FirstPage.LeftHeader.Text = ""
        .FirstPage.CenterHeader.Text = ""
        .FirstPage.RightHeader.Text = ""
        .FirstPage.LeftFooter.Text = ""
        .FirstPage.CenterFooter.Text = ""
        .FirstPage.RightFooter.Text = ""
    End With
    Application.PrintCommunication = False
    ActiveWindow.SelectedSheets.PrintOut Copies:=3, Collate:=True, _
        IgnorePrintAreas:=False
    Sheets("Each person").Select
    ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, _
        IgnorePrintAreas:=False
        Sheets("Each person").Select
    Range("E2:F37,K2:L37,Q2:R37,W2:X37,AC2:AD37,AI2:AJ37,AO2:AP37,AU2:AV37,BA2:BB37,BG2:BH37").Select
    Selection.ClearContents
        Sheets("Today").Copy Before:=Sheets(9)
     Range("A1:C1").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("A51:AG115").Select
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlToLeft
    Range("O2:AG50").Select
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlUp
        If Weekday(Date) = vbFriday Then
 Sheets("Today (2)").Name = Format(Date + 3, "mmddyy")
Else
 Sheets("Today (2)").Name = Format(Date + 1, "mmddyy")
 End If
 NextWorkDay = Date + 1
    'increment NextWorkDay if it is a weekend
    If Weekday(NextWorkDay, vbMonday) > 5 Then
        While Weekday(NextWorkDay, vbMonday) > 5
            NextWorkDay = NextWorkDay + 1
        Wend
 End If
       Sheets("Blank").Select
    Range("D2:M40").Select
    Range("M40").Activate
    Selection.Copy
    Sheets("Today").Select
    Range("D2").Select
    ActiveSheet.Paste
    Range("D5").Select
    
    
    ActiveWorkbook.Save
        
End Sub
 
Upvote 0
90% of this code does not add any value, start with removing all unnecessary lines and avoid selects.

For example, only the printarea line for pagesetup is relevant
 
Upvote 0
Solution
Thanks for that, while I dont really know what I am doing I managed to reduce alot of it but am getting an error now I dont understand. The bold command below is returning an error saying "We cant do that to a merged cell"

VBA Code: 
Sub DailyPrint()
'
' DailyPrint Macro
'
' Keyboard Shortcut: Ctrl+Shift+P
'
Sheets("Today").PrintOut Copies:=3
Sheets("Each Person").PrintOut Copies:=1
Sheets("Today").Copy Before:=Sheets(9)
     Sheets("Today").Copy Before:=Sheets(9)
     Range("A1:C1").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
[B]Sheets("Today (2)").Range("A48:AG115,N1:AG47").ClearContents[/B]
If Weekday(Date) = vbFriday Then
 Sheets("Today (2)").Name = Format(Date + 3, "mmddyy")
Else
 Sheets("Today (2)").Name = Format(Date + 1, "mmddyy")
 End If
 NextWorkDay = Date + 1
    'increment NextWorkDay if it is a weekend
    If Weekday(NextWorkDay, vbMonday) > 5 Then
        While Weekday(NextWorkDay, vbMonday) > 5
            NextWorkDay = NextWorkDay + 1
        Wend
    
End If
       Sheets("Blank").Select
    Range("D2:M40").Select
    Range("M40").Activate
    Selection.Copy
    Sheets("Today").Select
    Range("D2").Select
    ActiveSheet.Paste
    Range("D5").Select
    
    
    ActiveWorkbook.Save
        
End Sub
 
Upvote 0
Here is the untested version I have done so far, Try it and see if it still does what you want, and if it does, chop it down from there.

VBA Code: 
Sub DailyPrint()
'
' DailyPrint Macro
'
' Keyboard Shortcut: Ctrl+Shift+P
'
    ActiveSheet.pageSetup.PrintArea = "$A$1:$L$47"
    Application.PrintCommunication = False
'
    With ActiveSheet.pageSetup
        .LeftMargin = Application.InchesToPoints(0.25)
        .RightMargin = Application.InchesToPoints(0.25)
        .TopMargin = Application.InchesToPoints(0.25)
        .BottomMargin = Application.InchesToPoints(0.25)
        .CenterHorizontally = True
        .CenterVertically = True
        .Orientation = xlLandscape
        .Zoom = 55
    End With
'
    Application.PrintCommunication = False
    ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, IgnorePrintAreas:=False
'
'
    ActiveSheet.pageSetup.PrintArea = "$A$1:$M$47"
    Application.PrintCommunication = False
'
    With ActiveSheet.pageSetup
        .LeftMargin = Application.InchesToPoints(0.25)
        .RightMargin = Application.InchesToPoints(0.25)
        .TopMargin = Application.InchesToPoints(0.25)
        .BottomMargin = Application.InchesToPoints(0.25)
        .CenterHorizontally = True
        .CenterVertically = True
        .Orientation = xlLandscape
        .Zoom = False
        .FitToPagesWide = 1
        .FitToPagesTall = 1
    End With
'
    Application.PrintCommunication = False
    ActiveWindow.SelectedSheets.PrintOut Copies:=3, Collate:=True, IgnorePrintAreas:=False
'
    Sheets("Each person").Select
    ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, IgnorePrintAreas:=False
'
    Sheets("Each person").Range("E2:F37,K2:L37,Q2:R37,W2:X37,AC2:AD37,AI2:AJ37,AO2:AP37,AU2:AV37,BA2:BB37,BG2:BH37").ClearContents
'
    Sheets("Today").Copy Before:=Sheets(9)
    Sheets("Each person").Range("A1:C1").Copy
    Sheets("Each person").Range("A1:C1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
'
    Application.CutCopyMode = False
'
    Sheets("Each person").Range("A51:AG115").Delete Shift:=xlToLeft
    Sheets("Each person").Range("O2:AG50").Delete Shift:=xlUp
'
    If Weekday(Date) = vbFriday Then
        Sheets("Today (2)").Name = Format(Date + 3, "mmddyy")
    Else
        Sheets("Today (2)").Name = Format(Date + 1, "mmddyy")
    End If
'
    NextWorkDay = Date + 1
'
'   increment NextWorkDay if it is a weekend
    If Weekday(NextWorkDay, vbMonday) > 5 Then
        While Weekday(NextWorkDay, vbMonday) > 5
            NextWorkDay = NextWorkDay + 1
        Wend
    End If
'
    Sheets("Blank").Select
    Sheets("Blank").Range("M40").Activate
    Sheets("Blank").Range("D2:M40").Copy Sheets("Today").Range("D2")
    Sheets("Blank").Range("D5").Select
'
    ActiveWorkbook.Save
End Sub

It is difficult to do without seeing exactly what you are working with.
 
Upvote 0
Here are a few more lines that you can delete:

VBA Code: 
        .CenterHorizontally = True
        .CenterVertically = True
        .FitToPagesWide = 1
        .FitToPagesTall = 1
 
Upvote 0
here is what I got the code down to,

VBA Code: 
Sub DailyPrint()
'
' DailyPrint Macro
'
' Keyboard Shortcut: Ctrl+Shift+P
'
Sheets("Today").PrintOut Copies:=3
Sheets("Each Person").PrintOut Copies:=1
Sheets("Today").Copy Before:=Sheets(9)
         Range("A1:C1").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Sheets("Today (2)").Range("A48:AG130,N1:AG47").Clear
If Weekday(Date) = vbFriday Then
 Sheets("Today (2)").Name = Format(Date + 3, "mmddyy")
Else
 Sheets("Today (2)").Name = Format(Date + 1, "mmddyy")
 End If
 NextWorkDay = Date + 1
    'increment NextWorkDay if it is a weekend
    If Weekday(NextWorkDay, vbMonday) > 5 Then
        While Weekday(NextWorkDay, vbMonday) > 5
            NextWorkDay = NextWorkDay + 1
        Wend
    
End If
       Sheets("Blank").Range("D2:M47").Copy Sheets("Today").Range("D2:M47")
       Worksheets("Today").Activate
    
    ActiveWorkbook.Save
        
End Sub
 
Upvote 0
You must log in or register to reply here.

Similar threads

rjbinney
  • Solved
Error 1004 - Saving Macros in Macro-Free Workbooks
Replies
6
Views
350
rjbinney
rjbinney
B
  • Solved
Getting Macros to run automatically
Replies
3
Views
207
mumps
mumps
C
  • Question
Cut a row from "sheet 1" and paste onto "sheet2", run-time error '1004' "Paste method of Worksheet class failed"
2
Replies
10
Views
704
rpaulson
rpaulson
P
  • Question
Signature is being removed when I run the rest of my VBA
Replies
3
Views
163
rollis13
rollis13
J
  • Question
VBA Macros running slow out of nowhere
Replies
3
Views
208
mumps
mumps

Forum statistics

Threads
1,214,832
Messages
6,121,849
Members
449,051
Latest member
excelquestion515

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top