excel macro vba takes a long time to run

This is UNTESTED, but I hope it works and can be used for learning purposes.

I refactored part of it in order to show how to simplify a macro generated code.

Make a backup copy of your workbook before running it.

Run it by pressing F8 key and try to check where it fails and where it may take too long

‘ Read the comments and specially adjust target sheet name

Some suggestions:

  • Add Option Explicit at the top of your modules so Variables are always declared
  • Separate your code into logical steps (I used sub procedures to make it more readable)
  • Name your variables to something your future self or whoever maintains the code will understand

Code:

Public Sub PostSchedule()
    '

    ' Basic error handling
    On Error GoTo CleanFail
    
    ' Turn off stuff
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    
    ' Reference workbook, worksheet and pivot table
    Dim targetWorkbook As Workbook
    Set targetWorkbook = ThisWorkbook
    
    Dim targetsheet As Worksheet
    Set targetsheet = targetWorkbook.Worksheets("Sheet1")
    
    Dim pivotTable1 As PivotTable
    Set pivotTable1 = targetsheet.PivotTables("PivotTable1")
    
    
    ' Refresh source data
    pivotTable1.PivotCache.Refresh
    
    ' Clear slicers filters
    With targetWorkbook
        .SlicerCaches("Slicer_1_Sun").ClearManualFilter
        .SlicerCaches("Slicer_2_Mon").ClearManualFilter
        .SlicerCaches("Slicer_3_Tue").ClearManualFilter
        .SlicerCaches("Slicer_4_Wed").ClearManualFilter
        .SlicerCaches("Slicer_5_Thu").ClearManualFilter
        .SlicerCaches("Slicer_6_Fri").ClearManualFilter
        .SlicerCaches("Slicer_7_Sat").ClearManualFilter
    End With
    
    ' Setup pivot fields
    With pivotTable1
        .PivotFields("Shift").Orientation = xlRowField
        .PivotFields("Shift").Position = 6
        
        .PivotFields("Trainer").Orientation = xlRowField
        .PivotFields("Trainer").Position = 7
        
        .PivotFields("1 Sun").Orientation = xlRowField
        .PivotFields("1 Sun").Position = 8
        
        .PivotFields("2 Mon").Orientation = xlRowField
        .PivotFields("2 Mon").Position = 9
        
        .PivotFields("3 Tue").Orientation = xlRowField
        .PivotFields("3 Tue").Position = 10
            
        .PivotFields("4 Wed").Orientation = xlRowField
        .PivotFields("4 Wed").Position = 11
        
        .PivotFields("5 Thu").Orientation = xlRowField
        .PivotFields("5 Thu").Position = 12
        
        .PivotFields("6 Fri").Orientation = xlRowField
        .PivotFields("6 Fri").Position = 13
            
        .PivotFields("7 Sat").Orientation = xlRowField
        .PivotFields("7 Sat").Position = 14
        
        .PivotFields("LOA").Orientation = xlHidden
        .PivotFields("Present").Orientation = xlHidden
        
    End With
    
    ' Setup sheet for printing
    SetupSheet targetsheet
    
    ' Ajust slicer and print
    Dim shiftSlicer As SlicerCache
    Set shiftSlicer = targetWorkbook.SlicerCaches("Slicer_Shift")
    AdjustAndPrint shiftSlicer, targetsheet
    
    
    ' This part you can adjust it based on the other sub samples
    DoOtherStuff
    

CleanExit:
    ' Turn on stuff
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Exit Sub
 
CleanFail:
    Debug.Print "Something went wrong: " & Err.Description
    Resume CleanExit
    
End Sub

Private Sub SetupSheet(ByVal targetsheet As Worksheet)

    Application.PrintCommunication = False
    
    With targetsheet.PageSetup
        .PrintTitleRows = ""
        .PrintTitleColumns = ""
        .PrintArea = ""
        
        ' Other page properties
        .LeftHeader = "&""-,Bold""&18&U&K02-045????&U&K09+000 Crew Sheet"
        .CenterHeader = ""
        .RightHeader = "&D"
        .LeftFooter = ""
        .CenterFooter = ""
        .RightFooter = "&P of &N"
        .LeftMargin = Application.InchesToPoints(0.2)
        .RightMargin = Application.InchesToPoints(0.2)
        .TopMargin = Application.InchesToPoints(0.75)
        .BottomMargin = Application.InchesToPoints(0.75)
        .HeaderMargin = Application.InchesToPoints(0.3)
        .FooterMargin = Application.InchesToPoints(0.3)
        .PrintHeadings = False
        .PrintGridlines = False
        .PrintComments = xlPrintNoComments
        .PrintQuality = 600
        .CenterHorizontally = False
        .CenterVertically = False
        .Orientation = xlLandscape
        .Draft = False
        .PaperSize = xlPaperLetter
        .FirstPageNumber = xlAutomatic
        .Order = xlDownThenOver
        .BlackAndWhite = False
        .Zoom = 100
        .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 = True
    
End Sub

Private Sub AdjustAndPrint(ByVal shiftSlicer As SlicerCache, ByVal targetsheet As Worksheet)

    Dim slicerItemNames As Variant
    slicerItemNames = Array("12:00:00 AM", _
                        "12:30:00 AM", _
                        "1:30:00 AM", _
                        "4:00:00 AM", _
                        "8:00:00 AM", _
                        "8:30:00 AM", _
                        "10:00:00 AM", _
                        "11:00:00 AM", _
                        "11:30:00 AM", _
                        "12:30:00 AM", _
                        "3:00:00 PM", _
                        "4:00:00 PM", _
                        "11:00:00 PM", _
                        "11:30:00 PM", _
                        "(blank)")
    
    ' Loop through items, select and print
    Dim counter As Long
    For counter = 0 To UBound(slicerItemNames)
        
        ' Skip the blank
        If slicerItemNames(counter) = "(blank)" Then Exit For
        
        ' Inner loop to select each slicer once
        Dim innerCounter As Long
        For innerCounter = 0 To UBound(slicerItemNames)
            shiftSlicer.slicerItems(slicerItemNames(counter)).Selected = (counter = innerCounter)
        Next innerCounter
        
        ' Print each iteration
        targetsheet.PrintOut Copies:=1, Collate:=True, IgnorePrintAreas:=False
        
    Next counter

    ' Clear slicer filter
    shiftSlicer.ClearManualFilter

End Sub

Private Sub DoOtherStuff()

    With ActiveSheet.PivotTables("PivotTable1").PivotFields("1 Sun")
        .Orientation = xlRowField
        .Position = 6
    End With
    ActiveSheet.PivotTables("PivotTable1").PivotFields("1 Sun").Orientation = _
        xlHidden
    ActiveSheet.PivotTables("PivotTable1").PivotFields("2 Mon").Orientation = _
        xlHidden
    ActiveSheet.PivotTables("PivotTable1").PivotFields("4 Wed").Orientation = _
        xlHidden
    ActiveSheet.PivotTables("PivotTable1").PivotFields("5 Thu").Orientation = _
        xlHidden
    ActiveSheet.PivotTables("PivotTable1").PivotFields("6 Fri").Orientation = _
        xlHidden
    ActiveSheet.PivotTables("PivotTable1").PivotFields("7 Sat").Orientation = _
        xlHidden
    ActiveSheet.PivotTables("PivotTable1").PivotFields("3 Tue").Orientation = _
        xlHidden
    With ActiveSheet.PivotTables("PivotTable1").PivotFields("Trainer")
        .Orientation = xlRowField
        .Position = 3
    End With
    With ActiveSheet.PivotTables("PivotTable1").PivotFields("LOA")
        .Orientation = xlRowField
        .Position = 7
    End With
        With ActiveSheet.PivotTables("PivotTable1").PivotFields("1 Sun")
        .Orientation = xlRowField
        .Position = 8
    End With
    With ActiveSheet.PivotTables("PivotTable1").PivotFields("Present")
        .Orientation = xlRowField
        .Position = 9
    End With
    Application.PrintCommunication = False
    With ActiveSheet.PageSetup
        .PrintTitleRows = ""
        .PrintTitleColumns = ""
    End With
    Application.PrintCommunication = True
    ActiveSheet.PageSetup.PrintArea = ""
    Application.PrintCommunication = False
    With ActiveSheet.PageSetup
        .LeftHeader = "&""-,Bold""&18&U&K02-045????&U&K09+000 Crew Sheet"
        .CenterHeader = ""
        .RightHeader = "&D"
        .LeftFooter = ""
        .CenterFooter = ""
        .RightFooter = "&P of &N"
        .LeftMargin = Application.InchesToPoints(0.2)
        .RightMargin = Application.InchesToPoints(0.2)
        .TopMargin = Application.InchesToPoints(0.75)
        .BottomMargin = Application.InchesToPoints(0.75)
        .HeaderMargin = Application.InchesToPoints(0.3)
        .FooterMargin = Application.InchesToPoints(0.3)
        .PrintHeadings = False
        .PrintGridlines = False
        .PrintComments = xlPrintNoComments
        .PrintQuality = 600
        .CenterHorizontally = False
        .CenterVertically = False
        .Orientation = xlPortrait
        .Draft = False
        .PaperSize = xlPaperLetter
        .FirstPageNumber = xlAutomatic
        .Order = xlDownThenOver
        .BlackAndWhite = False
        .Zoom = 100
        .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 = True
    With ActiveWorkbook.SlicerCaches("Slicer_1_Sun")
        .slicerItems("6am").Selected = True
        .slicerItems("off").Selected = False
        .slicerItems("x").Selected = True
        .slicerItems("6th").Selected = True
        .slicerItems("5th").Selected = True
        .slicerItems("PTO").Selected = True
        .slicerItems("(blank)").Selected = False
    End With
End Sub

You’re doing a lot of printing, so also check if printer communication may be affecting your macro run time.

Let me know how it goes

CLICK HERE to find out more related problems solutions.

Leave a Comment

Your email address will not be published.

Scroll to Top