Slow running macro - excel

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

Answer 1

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

Answer 2

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

Answer 3

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