Slow running macro

Question

I've created a macro (using lots of online help) to take data from one sheet, create another sheet, format the data and set up the printer. Everything works as it should but the macro seems to take a long time to run. Would someone be able to look at my code and see if I've done something that I shouldn't?

Thanks

Sub Preactor_Sort()
    Application.ScreenUpdating = False
'**Copy "Full List" Data into New Sheet**
    Sheets("FULL LIST").Select
    Range("A8:R8").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Sheets.Add(Before:=Sheets("MASTER")).Name = "Sorted Full"
    Range("A1").Select
    ActiveSheet.Paste
    ActiveWindow.Zoom = 60
'**************************************************
'**Formatting and removing previous conditional formatting**
    Cells.FormatConditions.Delete
    Cells.Select
    With Selection.Font
        .Name = "Calibri"
        .Size = 9
        .Bold = False
        .Color = vbBlack
    End With
    With Selection
        .VerticalAlignment = xlCenter
        .HorizontalAlignment = xlCenter
        .WrapText = True
        .Interior.ColorIndex = 0
        .RowHeight = 23
    End With
    Cells.EntireColumn.AutoFit
'***************************************************
'**Deleting Unwanted Columns**
    Columns("E:E").Select
    Selection.Cut
    Columns("C:C").Select
    Selection.Insert Shift:=xlToRight
    Columns("A:C").Select
    Range("A1").Activate
    Selection.Delete Shift:=xlToLeft
'***************************************************
'**Rearranging Columns**
    Columns("G:H").Select
    Selection.Cut
    Columns("B:B").Select
    Selection.Insert Shift:=xlToRight
    Columns("K:L").Select
    Selection.Cut
    Columns("E:E").Select
    Selection.Insert Shift:=xlToRight
'****************************************************
'**Sorting Day/Date**
    Columns("C:C").Select
    Selection.NumberFormat = "dd/mm/yy hh:mm"
    Columns("C:C").EntireColumn.AutoFit
    Columns("C:C").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Columns("C:C").Select
    Selection.NumberFormat = "General"
    '**Find Last Row**
    LR = Cells.Find("*", Cells(1, 1), xlFormulas, xlPart, xlByRows, xlPrevious, False).Row
    '**Insert Formula**
    Range("C2").Formula = "=TEXT(D2,""ddd"")"
    '**Drag Formula down to last row**
    Range("C2").AutoFill Range("C2:C" & LR)
    Columns("C:C").EntireColumn.AutoFit
'*****************************************************
'**Sorting**
    With ActiveSheet.Sort
        .SortFields.Add2 Key:=Range("C1"), Order:=xlAscending, CustomOrder:="Mon,Tue,Wed,Thu,Fri,Sat,Sun", DataOption:=xlSortNormal
        .SortFields.Add2 Key:=Range("B1"), SortOn:=xlSortOnValues, Order:=xlAscending, CustomOrder:="Make,Discharge,Packing,Wrapping", DataOption:=xlSortNormal
        .SetRange Range("A:P")
        .Header = xlYes
        .Apply
    End With
'******************************************************
'**Formatting**
    Range("C:C,E:E").Select
    With Selection
        .Font.Bold = True
    End With
    Columns("B:B").Select
    Selection.ColumnWidth = 10
    Columns("F:G").Select
    Selection.ColumnWidth = 25
    Columns("A:A").Select
    Selection.ColumnWidth = 8
    Columns("I:J").Select
    Selection.ColumnWidth = 5
    Columns("L:N").Select
    Selection.ColumnWidth = 15
    Columns("O:O").Select
    Selection.ColumnWidth = 80
    Columns("H:H").Select
    Selection.ColumnWidth = 40
    Columns("K:K").Select
    Selection.ColumnWidth = 6
'**Conditional Formatting**
'** Alternating Rows
    Dim lastRow As Long
    lastRow = Range("A1:P1").End(xlDown).Row
    For Each cell In Range("A1:P" & lastRow)
        If cell.Row Mod 2 = 1 Then
            cell.Interior.ColorIndex = 34 'Light Blue
        End If
    Next cell
'**Highlighting Operations
    Dim cell1 As Range
    For Each cell1 In Range("B:B")
        If cell1.Value = "Make" Then
        cell1.Interior.ColorIndex = 35 'Light Green
        ElseIf cell1.Value = "Discharge" Then
        cell1.Interior.ColorIndex = 36 'Light Yellow
        ElseIf cell1.Value = "Packing" Then
        cell1.Interior.ColorIndex = 19 'Light Cream
        ElseIf cell1.Value = "Wrapping" Then
        cell1.Interior.ColorIndex = 6 'Yellow
        ElseIf cell1.Value = "Boxing" Then
        cell1.Interior.ColorIndex = 44 'Light Orange
        ElseIf cell1.Value = "Oil Phase" Then
        cell1.Interior.ColorIndex = 38 'Pink
        End If
    Next
'**Highlighting Day
    Dim cell2 As Range
    For Each cell2 In Range("C:C")
        If cell2.Value = "Mon" Then
        cell2.Interior.ColorIndex = 7 'Pink
        ElseIf cell2.Value = "Tue" Then
        cell2.Interior.ColorIndex = 4 'Green
        ElseIf cell2.Value = "Wed" Then
        cell2.Interior.ColorIndex = 6 'Yellow
        ElseIf cell2.Value = "Thu" Then
        cell2.Interior.ColorIndex = 45 'Orange
        ElseIf cell2.Value = "Fri" Then
        cell2.Interior.ColorIndex = 33 'Blue
        End If
    Next
'** Top Bar Colour
    Range("A1:P1").Select
    With Selection
        .Interior.ColorIndex = 15
        .Font.Bold = True
    End With
'*********************************************************
'** Printer Setup
    Application.PrintCommunication = True
    With ActiveSheet.PageSetup
        .PrintTitleRows = ""
        .PrintTitleColumns = ""
    End With
    ActiveSheet.PageSetup.PrintArea = ""
    With ActiveSheet.PageSetup
        .LeftMargin = Application.InchesToPoints(0.12)
        .RightMargin = Application.InchesToPoints(0.12)
        .TopMargin = Application.InchesToPoints(0.16)
        .BottomMargin = Application.InchesToPoints(0.16)
        .HeaderMargin = Application.InchesToPoints(0.12)
        .FooterMargin = Application.InchesToPoints(0.12)
        .PrintHeadings = False
        .PrintGridlines = False
        .PrintComments = xlPrintNoComments
        .PrintQuality = 600
        .CenterHorizontally = True
        .CenterVertically = False
        .Orientation = xlLandscape
        .Draft = False
        .PaperSize = xlPaperA3
        .FirstPageNumber = xlAutomatic
        .Order = xlDownThenOver
        .BlackAndWhite = False
        .Zoom = False
        .FitToPagesWide = 1
        .FitToPagesTall = False
        .PrintErrors = xlPrintErrorsDisplayed
        .OddAndEvenPagesHeaderFooter = False
        .DifferentFirstPageHeaderFooter = False
        .ScaleWithDocHeaderFooter = True
        .AlignMarginsHeaderFooter = True
    End With
   ' Application.PrintCommunication = False
End Sub

Please have a look on [how-to-avoid-using-select](https://stackoverflow.com/questions/10714251/how-to-avoid-using-select-in-excel-vba) — Shrotter, Nov 02 '22 at 10:07

score 0 · Answer 1 · answered Nov 02 '22 at 10:46

Trying adding in this, it speeds up by turning off screen updating, events, animations etc, this should speed it up a bit!

At the start of your code add in this sub

Call TurnOffCode

At the end of your code add in this sub

Call TurnOnCode

This is what they should both look like

Sub TurnOffCode() 'Used to turn off settings to make workbook run faster
Application.Calculation = xlCalculationManual 'Set calculations to manual
Application.ScreenUpdating = False 'Turns off screen updating
Application.EnableEvents = False 'Turns off events
Application.EnableAnimations = False 'Turns off animations
Application.DisplayStatusBar = False 'Turns off display status bar
Application.PrintCommunication = False 'Turns off print communications
End Sub

Sub TurnOnCode() 'Used to turn settings back on to normal
Application.Calculation = xlCalculationAutomatic 'Set calculations to automatic
Application.ScreenUpdating = True 'Turns on screen updating
Application.EnableEvents = True 'Turns on events
Application.EnableAnimations = True 'Turns on animations
Application.DisplayStatusBar = True 'Turns on display status bar
Application.PrintCommunication = True 'Turns on print communications
End Sub

However, you should also avoid using selects as well, look at the comment section for a page displaying that information

score 0 · Answer 2 · answered Nov 02 '22 at 13:30

Thanks for looking at this for me.

I tried the solution that EuanM28 offered and this did marginally increase the speed - from 38sec to around 34sec.

I made a couple of tweaks to my code from

Dim cell1 As Range
For Each cell1 In Range("B:B")

to

Dim cell1 As Range
For Each cell1 In Range("B2:B" & LR) '*LR = last row variable defined earlier in the code

and

Dim cell2 As Range
For Each cell2 In Range("C:C")

to

Dim cell2 As Range
For Each cell2 In Range("C2:C" & LR)

This made a huge difference (34sec to 6sec) I'm guessing because it's no longer cycling through all the rows on the sheet and just the populated ones.

I will have to look into removing .Selects as suggested (didn't realise it causes so many issues!)

Thanks

mtholen · Answer 3 · 2022-11-03T09:19:33.253

You have a lot of select statements in your code only to subsequently do something with the selection you can avoid that.

A section like the below

    Application.ScreenUpdating = False
    '**Copy "Full List" Data into New Sheet**
    Sheets("FULL LIST").Select
    Range("A8:R8").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Sheets.Add(Before:=Sheets("MASTER")).Name = "Sorted Full"
    Range("A1").Select
    ActiveSheet.Paste
    ActiveWindow.Zoom = 60
'**************************************************
'**Formatting and removing previous conditional formatting**
    Cells.FormatConditions.Delete
    Cells.Select
    With Selection.Font
        .Name = "Calibri"
        .Size = 9
        .Bold = False
        .Color = vbBlack
    End With
    With Selection
        .VerticalAlignment = xlCenter
        .HorizontalAlignment = xlCenter
        .WrapText = True
        .Interior.ColorIndex = 0
        .RowHeight = 23
    End With
    Cells.EntireColumn.AutoFit

can be rewritten as:

    Dim slc As Range
    Dim rng As Range

    'Application.ScreenUpdating = False <= be careful with setting update to false as it will not restore if your program encounters an error!
    '**Copy "Full List" Data into New Sheet**

    Set rng = Sheets(1).Range("A8:R8")
    Set slc = Range(rng, rng.End(xlDown))
    slc.Copy
    
    Sheets.Add(Before:=Sheets(1)).Name = "Sorted Full"
    Sheets("Sorted Full").Paste
    ActiveWindow.Zoom = 60
'**************************************************
'**Formatting and removing previous conditional formatting**
    Cells.FormatConditions.Delete
    With Cells.Font
        .Name = "Calibri"
        .Size = 9
        .Bold = False
        .Color = vbBlack
    End With
    With Cells
        .VerticalAlignment = xlCenter
        .HorizontalAlignment = xlCenter
        .WrapText = True
        .Interior.ColorIndex = 0
        .RowHeight = 23
    End With
    Cells.EntireColumn.AutoFit

This will prevent Excel from making the select statement which is causing the slow execution and flickering of the screen.

If you apply that throughout your code you will have a much cleaner execution, without the need to turn off screen updating.

So, if you clean up your code a bit it can look like below: Mind you, even this has plenty of room for improvement but at least it get's rid of most of the select statements.

This can still be combined with the solution proposed by @EuanM28 However, there are some drawbacks with switching of calculation and screenupdates that may require appropriate ErrorHandling in case your macro encounters an error.

So, combining them would look like the below:

    Sub Preactor_Sort()
    On Error GoTo ErrorHandler '<= called in case of an Error
    Call ToggleCode(False)
    
    Dim slc As Range
    Dim rng As Range

    'Application.ScreenUpdating = True
    '**Copy "Full List" Data into New Sheet**
    
    Set rng = Sheets(1).Range("A8:R8")
    Set slc = Range(rng, rng.End(xlDown))
    slc.Copy
    
    Sheets.Add(Before:=Sheets(1)).Name = "Sorted Full"
    Sheets("Sorted Full").Paste
    ActiveWindow.Zoom = 60
    '**************************************************
    
    '**Formatting and removing previous conditional formatting**
    With Cells
        .FormatConditions.Delete
        .VerticalAlignment = xlCenter
        .HorizontalAlignment = xlCenter
        .WrapText = True
        .Interior.ColorIndex = 0
        .RowHeight = 23
        With .Font
            .Name = "Calibri"
            .Size = 9
            .Bold = False
            .Color = vbBlack
        End With
        .EntireColumn.AutoFit
    End With
    '***************************************************
    
    '**Deleting Unwanted Columns**
    columns("E:E").Cut
    columns("C:C").Insert Shift:=xlToRight
    columns("A:C").Delete Shift:=xlToLeft
    '***************************************************
    
    '**Rearranging Columns**
    columns("G:H").Cut
    columns("B:B").Insert Shift:=xlToRight
    columns("K:L").Cut
    columns("E:E").Insert Shift:=xlToRight
    '****************************************************
    
    '**Sorting Day/Date**
    columns("C:C").NumberFormat = "dd/mm/yy hh:mm"
    columns("C:C").EntireColumn.AutoFit
    columns("C:C").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    columns("C:C").NumberFormat = "General"
    '**Find Last Row**
    LR = Cells.Find("*", Cells(1, 1), xlFormulas, xlPart, xlByRows, xlPrevious, False).row
    '**Insert Formula**
    Range("C2").Formula = "=TEXT(D2,""ddd"")"
    '**Drag Formula down to last row**
    Range("C2").AutoFill Range("C2:C" & LR)
    columns("C:C").EntireColumn.AutoFit
    '*****************************************************
    
    '**Sorting**
    With ActiveSheet.Sort
        .SortFields.Add2 Key:=Range("C1"), Order:=xlAscending, CustomOrder:="Mon,Tue,Wed,Thu,Fri,Sat,Sun", DataOption:=xlSortNormal
        .SortFields.Add2 Key:=Range("B1"), SortOn:=xlSortOnValues, Order:=xlAscending, CustomOrder:="Make,Discharge,Packing,Wrapping", DataOption:=xlSortNormal
        .SetRange Range("A:P")
        .Header = xlYes
        .Apply
    End With
    '******************************************************
    
    '**Formatting**
    Range("C:C,E:E").Font.Bold = True
    columns("B:B").ColumnWidth = 10
    columns("F:G").ColumnWidth = 25
    columns("A:A").ColumnWidth = 8
    columns("I:J").ColumnWidth = 5
    columns("L:N").ColumnWidth = 15
    columns("O:O").ColumnWidth = 80
    columns("H:H").ColumnWidth = 40
    columns("K:K").ColumnWidth = 6
    '**Conditional Formatting**
    '** Alternating Rows
    Dim lastRow As Long
    lastRow = Range("A1:P1").End(xlDown).row
    For Each cell In Range("A1:P" & lastRow)
        If cell.row Mod 2 = 1 Then
            cell.Interior.ColorIndex = 34 'Light Blue
        End If
    Next cell
        '**Highlighting Operations
    Dim cell1 As Range
    For Each cell1 In Range("B:B")
        If cell1.value = "Make" Then
        cell1.Interior.ColorIndex = 35 'Light Green
        ElseIf cell1.value = "Discharge" Then
        cell1.Interior.ColorIndex = 36 'Light Yellow
        ElseIf cell1.value = "Packing" Then
        cell1.Interior.ColorIndex = 19 'Light Cream
        ElseIf cell1.value = "Wrapping" Then
        cell1.Interior.ColorIndex = 6 'Yellow
        ElseIf cell1.value = "Boxing" Then
        cell1.Interior.ColorIndex = 44 'Light Orange
        ElseIf cell1.value = "Oil Phase" Then
        cell1.Interior.ColorIndex = 38 'Pink
        End If
    Next
    '**Highlighting Day
    Dim cell2 As Range
    For Each cell2 In Range("C:C")
        If cell2.value = "Mon" Then
        cell2.Interior.ColorIndex = 7 'Pink
        ElseIf cell2.value = "Tue" Then
        cell2.Interior.ColorIndex = 4 'Green
        ElseIf cell2.value = "Wed" Then
        cell2.Interior.ColorIndex = 6 'Yellow
        ElseIf cell2.value = "Thu" Then
        cell2.Interior.ColorIndex = 45 'Orange
        ElseIf cell2.value = "Fri" Then
        cell2.Interior.ColorIndex = 33 'Blue
        End If
    Next
    '** Top Bar Colour
    'Range("A1:P1").Select
    With Range("A1:P1")
        .Interior.ColorIndex = 15
        .Font.Bold = True
    End With
    '*********************************************************
    
    '** Printer Setup
    'Application.PrintCommunication = True
    With ActiveSheet.PageSetup
        .PrintTitleRows = ""
        .PrintTitleColumns = ""
    End With
    ActiveSheet.PageSetup.PrintArea = ""
    With ActiveSheet.PageSetup
        .LeftMargin = Application.InchesToPoints(0.12)
        .RightMargin = Application.InchesToPoints(0.12)
        .TopMargin = Application.InchesToPoints(0.16)
        .BottomMargin = Application.InchesToPoints(0.16)
        .HeaderMargin = Application.InchesToPoints(0.12)
        .FooterMargin = Application.InchesToPoints(0.12)
        .PrintHeadings = False
        .PrintGridlines = False
        .PrintComments = xlPrintNoComments
        .PrintQuality = 600
        .CenterHorizontally = True
        .CenterVertically = False
        .Orientation = xlLandscape
        .Draft = False
        .PaperSize = xlPaperA3
        .FirstPageNumber = xlAutomatic
        .Order = xlDownThenOver
        .BlackAndWhite = False
        .Zoom = False
        .FitToPagesWide = 1
        .FitToPagesTall = False
        .PrintErrors = xlPrintErrorsDisplayed
        .OddAndEvenPagesHeaderFooter = False
        .DifferentFirstPageHeaderFooter = False
        .ScaleWithDocHeaderFooter = True
        .AlignMarginsHeaderFooter = True
    End With
   ' Application.PrintCommunication = False
   Call ToggleCode(True)
Exit Sub

ErrorHandler:
    Call ToggleCode(True) '<= this ensures your application get's reset in case of an Error

End Sub

Sub ToggleCode(Optional switch As Boolean = True) 'Used to turn on/off settings to make workbook run faster
    If (switch) Then
        Application.Calculation = xlCalculationAutomatic  'Set calculations to automatic
    Else
        Application.Calculation = xlCalculationManual  'Set calculations to manual
    End If
    
    Application.ScreenUpdating = switch 'Turns on/off screen updating
    Application.EnableEvents = switch 'Turns on/off events
    Application.EnableAnimations = switch 'Turns on/off animations
    Application.DisplayStatusBar = switch 'Turns on/off display status bar
    Application.PrintCommunication = switch 'Turns on/off print communications
End Sub

Slow running macro

3 Answers3

Linked