Macro running slow

  • Thread starter Thread starter Mike Magill
  • Start date Start date
M

Mike Magill

Hi,

I'm self taught so my coding is very inefficient. Up until now this
hasn't been a problem but my latest effort is taking far too long to
run. Can anyone advice on where the bottleneck is and how I can speed
it up?

Thanks

Mike

CODE BELOW (sorry for the amount)
--------------------

ActiveSheet.Unprotect Password:="XXXXXXX" ' Unprotects the
worksheet
Application.ScreenUpdating = False ' Stops the screen
refreshing while the macro is running

UserForm2.Show

' Reprotect the worksheet and end macro

Range("I4").Select
ActiveSheet.Protect Password:="XXXXXXX", DrawingObjects:=True,
Contents:=True, Scenarios:=True
Application.ScreenUpdating = True


UserForm2 CODE
----------------------

Private Sub CommandButton2_Click()
Dim x As Control
Dim PaperSize As String
Dim ReportType As String

For Each x In Frame2.Controls ' Loop through the option buttons
' within the Frame
If x.Value = True Then
PaperSize = Left(x.Caption, 2)
End If ' option button
Next

With ActiveSheet.PageSetup '
Set Page Setup
If PaperSize = "A3" Then
.PaperSize = xlPaperA3
Else
.PaperSize = xlPaperA4
End If

End With

If CheckBox1.Value = True Then

Columns("J:J").Select ' Hide Local Risk
Description column
Range("J6").Activate
Selection.EntireColumn.Hidden = True

Columns("BQ:BQ").Select ' Hide Local Risk
Description column
Range("BQ6").Activate
Selection.EntireColumn.Hidden = True


Else
End If

If CheckBox2.Value = True Then

Columns("C:F").Select ' Hide Assessment
Criteria columns
Selection.EntireColumn.Hidden = True
Columns("L:O").Select
Selection.EntireColumn.Hidden = True


Else
End If





For Each x In Frame1.Controls ' Loop through the option
buttons
' within the Frame
If x.Value = True Then
ReportType = x.Caption
End If ' option button
Next

Select Case ReportType

Case "Full Risk Register"

Call Print_Full_Register

Case "Summary Risk Register"

Call Print_Summary

Case "Red Individual Control Assessments"

Range("BL6").Value = "Red"
Call Overdue_Actions

Case "Amber Individual Control Assessments"

Range("BL6").Value = "Amber"
Call Overdue_Actions

Case "Red & Amber Individual Control Assessments"

Range("BL6").Value = "Red/Amber"
Call Overdue_Actions

Case "Overdue Actions"

Range("BL6").Value = "Action"
Call Overdue_Actions


Case Else

'Whatever

End Select

Columns("J:J").Select ' Unhide Local Risk
Description column
Range("J6").Activate
Selection.EntireColumn.Hidden = False

Columns("BQ:BQ").Select ' Unhide Local Risk
Description column
Range("BQ6").Activate
Selection.EntireColumn.Hidden = False


Columns("C:F").Select ' Show Assessment
Criteria columns
Selection.EntireColumn.Hidden = False
Columns("L:O").Select
Selection.EntireColumn.Hidden = False


Unload Me
End Sub



Sub Print_Full_Register()
'
' This macro prints the full risk register but only showing rows with
data
'

Call Row_Heights ' Macro to return heights of Rows 1-6 to their
preset heights

Call Action_Tidy_Up ' Macro to remove any extraneous spaces in
cells within the Action
' columns to highlight the need to complete
relevant actions properly


Call Print_Prep ' Macro to prepare rows for printing by ensure
all rows are expanded to show all text

Call Print_Report ' Macro to prepare rows for printing by ensure
only rows containing data are visible and then print


End Sub


Sub Print_Summary()
'
' This macro prints a summary report that excludes the control and
action details
'

Call Row_Heights ' Macro to return heights of Rows 1-6 to their
preset heights

Call Action_Tidy_Up ' Macro to remove any extraneous spaces in
cells within the Action
' columns to highlight the need to complete
relevant actions properly


Call Print_Prep ' Macro to prepare rows for printing by ensure
all rows are expanded to show all text

Rows("1:1").Select ' Hide control
panel when printing
Selection.EntireRow.Hidden = True
Columns("J:J").Select ' Hide Local Risk
Description
Selection.EntireColumn.Hidden = True
Selection.AutoFilter Field:=2, Criteria1:="<>" ' Filter data to
one line per risk

With ActiveSheet.PageSetup ' Set Page Setup
.PrintTitleRows = "$2:$6"
.PrintTitleColumns = ""
.PrintArea = "$A:$T"
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = False
End With

If Application.Dialogs(xlDialogPrinterSetup).Show Then
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True '
Print one copy

Else
End If

With ActiveSheet.PageSetup ' Reset Page Setup
to default
.PrintArea = "$A:$AB"
End With

Rows("1:1").Select ' Unhide control
panel when printing
Selection.EntireRow.Hidden = False
Columns("J:J").Select ' Unhide Local
Risk Description
Selection.EntireColumn.Hidden = False
Selection.AutoFilter Field:=2 ' Filter data to
show all rows


End Sub


Sub Overdue_Actions()
'
' Overdue Actions Macro
' Macro recorded 01/06/2009 by mike.magill
'

'

Call Row_Heights ' Macro to return heights of Rows 1-6 to their
preset heights

Call Action_Tidy_Up ' Macro to remove any extraneous spaces in
cells within the Action
' columns to highlight the need to complete
relevant actions properly

' Check the user wants to print the risk register


Columns("BM:CB").Select
Selection.EntireColumn.Hidden = False


Selection.AutoFilter Field:=64 ' Filter to show
just Overdue Actions
Selection.AutoFilter Field:=64, Criteria1:=Range("BL6")

Call Print_Prep ' Macro to prepare rows for printing by ensure
all rows are expanded to show all text


With ActiveSheet.PageSetup '
Set Page Setup
.PrintTitleRows = "$2:$6"
.PrintTitleColumns = ""
.PrintArea = "$BM:$CB"
.Orientation = xlLandscape
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = False
End With

Rows("1:1").Select
Selection.EntireRow.Hidden = True '
Hide control panel when printing

If Application.Dialogs(xlDialogPrinterSetup).Show Then
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True '
Print one copy

Else
End If

Rows("1:1").Select '
Reveal control panel
Selection.EntireRow.Hidden = False

With ActiveSheet.PageSetup '
Set Page Setup
.PrintTitleRows = "$2:$6"
.PrintTitleColumns = ""
.PrintArea = "$A:$AB"
.Orientation = xlLandscape
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = False
End With

Selection.AutoFilter Field:=64 ' Filter to show
just Overdue Actions



Columns("BM:CB").Select
Selection.EntireColumn.Hidden = True

Range("i4").Select

End Sub


Sub Row_Heights()
'
' Macro to return heights of Rows 1-6 to their preset heights
'

Rows("1:1").Select
Selection.RowHeight = 132.75
Rows("2:2").Select
Selection.RowHeight = 20.25
Rows("3:3").Select
Selection.RowHeight = 15.75
Rows("4:4").Select
Selection.RowHeight = 19.5
Rows("5:5").Select
Selection.RowHeight = 19.5
Rows("6:6").Select
Selection.RowHeight = 38.25

End Sub


Sub Action_Tidy_Up()
'
' Macro to remove any extraneous spaces in cells within the Action
' columns to highlight the need to complete relevant actions properly

Dim rng As Range
Set rng = Range("y7:ab310")
Dim cell As Range
For Each cell In rng
If Trim(cell.Value) = "" Then
ActiveSheet.Range(cell, cell).ClearContents
End If
Next

End Sub


Sub Print_Prep()
'
' Macro to prepare rows for printing by ensure all rows are expanded
to
' show all text

Rows("7:310").Select
Range("b7").Activate
Rows("7:310").EntireRow.AutoFit

End Sub

Sub Print_Report()
'
' Macro to prepare rows for printing by ensure only rows containing
data
' are visible and then print one copy


With ActiveSheet.PageSetup '
Set Page Setup
.PrintTitleRows = "$2:$6"
.PrintTitleColumns = ""
.PrintArea = "$A:$AB"
.Orientation = xlLandscape
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = False

End With

Rows("1:1").Select
Selection.EntireRow.Hidden = True '
Hide control panel when printing

Selection.AutoFilter Field:=30, Criteria1:="x" '
Hide rows with no data

If Application.Dialogs(xlDialogPrinterSetup).Show Then
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True '
Print one copy

Else
End If

Selection.AutoFilter Field:=30 '
Show rows with no data

Rows("1:1").Select '
Reveal control panel
Selection.EntireRow.Hidden = False

End Sub
 
In the frame where paper size is chosen, why not just have two
options: A3 and A4? That would save a few lines of code.

You don't need to select columns to hide them, you can replace the
following lines:

If CheckBox1.Value = True Then
Columns("J:J").Select ' Hide Local Risk
Description Column
Range("J6").Activate
Selection.EntireColumn.Hidden = True

Columns("BQ:BQ").Select ' Hide Local Risk
Description Column
Range("BQ6").Activate
Selection.EntireColumn.Hidden = True

Else
End If

If CheckBox2.Value = True Then

Columns("C:F").Select ' Hide Assessment
Criteria Columns
Selection.EntireColumn.Hidden = True
Columns("L:O").Select
Selection.EntireColumn.Hidden = True

Else
End If

with:

If CheckBox1.Value Then
Columns("J:J").Hidden = True
Columns("BQ:BQ").Hidden = True
End If

If CheckBox2.Value Then
Columns("C:F").EntireColumn.Hidden = True
Columns("L:O").EntireColumn.Hidden = True
End If

Since there's no "Else" condition, there's no need to include an empty
Else clause.

It looks like you hide columns, then unhide them before the userform
is unloaded. Is that really necessary?

There's an awful lot of Selecting going on. Most places where you
have .Select followed by Selection., you can concatenate them into one
line. Row_Heights could be rewritten like this:

Sub Row_Heights()
'
' Macro to return heights of Rows 1-6 to their preset heights
'
Dim i As Long

For i = 1 To 6
Select Case i
Case 1
Rows(i).RowHeight = 132.75
Case 2
Rows(i).RowHeight = 20.25
Case 3
Rows(i).RowHeight = 15.75
Case 4
Rows(i).RowHeight = 19.5
Case 5
Rows(i).RowHeight = 19.5
Case 6
Rows(i).RowHeight = 38.25
End Select
Next i
End Sub

But I have to question why row heights need to be adjusted in a macro.

Your macro Action_Tidy_Up selects and loops through approx. 1200
cells. Instead, read the range into an array and loop through the
array in memory. For sample code, see
http://www.codeforexcelandoutlook.com/excel-vba/calculation-mode-and-excel-optimization/
and loop for the BetterLoop procedure.

HTH,
JP

Hi,

I'm self taught so my coding is very inefficient.  Up until now this
hasn't been a problem but my latest effort is taking far too long to
run.  Can anyone advice on where the bottleneck is and how I can speed
it up?

Thanks

Mike
Click to expand...
-- snip --
 
That should have read " ... and look for the BetterLoop procedure."

--JP






- Show quoted text -
Click to expand...

Thanks for the suggestions. They appear to have helped improve the
speed but it still takes about 11 seconds from pressing OK on the
UserForm to the Print Dialog box appearing. Do you have any other
suggestions?
 
Thanks for the suggestions.  They appear to have helped improve the
speed but it still takes about 11 seconds from pressing OK on the
UserForm to the Print Dialog box appearing.  Do you have any other
suggestions?
Click to expand...

I experienced the same slow-down you are describing. It comes with the
page-setup portion of your code. I believe it's with the fit to pages
wide/tall part. I'm not sure why these commands take so long to run.
I've tried a few work-arounds but have come up short myself. To double
check if this is the issue, try commenting these portions out, and
even though it may not print the way you like it, it should run
faster.
 
Thanks for all your help so far. Commenting out the Page Setup code
did not noticeably speed the code up. Revised code so far:


Sub Print_Options()
'
' This macro prints the full risk register but only showing rows with
data
'
ActiveSheet.Unprotect Password:="XXXXX" ' Unprotects the
worksheet
Application.ScreenUpdating = False ' Stops the screen
refreshing while the macro is running

UserForm2.Show

' Reprotect the worksheet and end macro

Range("I4").Select
ActiveSheet.Protect Password:="XXXXX", DrawingObjects:=True,
Contents:=True, Scenarios:=True
Application.ScreenUpdating = True


End Sub



Private Sub CommandButton2_Click()
Dim x As Control
Dim PaperSize As String
Dim ReportType As String

For Each x In Frame2.Controls ' Loop through the option buttons
' within the Frame
If x.Value = True Then
PaperSize = Left(x.Caption, 2)
End If ' option button
Next

With ActiveSheet.PageSetup '
Set Page Setup
If PaperSize = "A3" Then
.PaperSize = xlPaperA3
Else
.PaperSize = xlPaperA4
End If

End With

If CheckBox1.Value Then
Columns("J:J").EntireColumn.Hidden = True
Columns("BQ:BQ").EntireColumn.Hidden = True
End If


If CheckBox2.Value Then
Columns("C:F").EntireColumn.Hidden = True
Columns("L:O").EntireColumn.Hidden = True
End If


For Each x In Frame1.Controls ' Loop through the option
buttons
' within the Frame
If x.Value = True Then
ReportType = x.Caption
End If ' option button
Next

Select Case ReportType

Case "Full Risk Register"

Call Print_Full_Register

Case "Summary Risk Register"

Call Print_Summary

Case "Red Individual Control Assessments"

Range("BL6").Value = "Red"
Call Overdue_Actions

Case "Amber Individual Control Assessments"

Range("BL6").Value = "Amber"
Call Overdue_Actions

Case "Red & Amber Individual Control Assessments"

Range("BL6").Value = "Red/Amber"
Call Overdue_Actions

Case "Overdue Actions"

Range("BL6").Value = "Action"
Call Overdue_Actions


Case Else

'Whatever

End Select

Columns("J:J").EntireColumn.Hidden = False
Columns("BQ:BQ").EntireColumn.Hidden = False

Columns("C:F").EntireColumn.Hidden = False
Columns("L:O").EntireColumn.Hidden = False

Unload Me
End Sub


Sub Print_Full_Register()
'
' This macro prints the full risk register but only showing rows with
data
'

Call Row_Heights ' Macro to return heights of Rows 1-6 to their
preset heights

Call Action_Tidy_Up ' Macro to remove any extraneous spaces in
cells within the Action
' columns to highlight the need to complete
relevant actions properly


Rows("7:310").EntireRow.AutoFit

Call Print_Report ' Macro to prepare rows for printing by ensure
only rows containing data are visible and then print


End Sub


Sub Row_Heights()
'
' Macro to return heights of Rows 1-6 to their preset heights
'

Dim i As Long


For i = 1 To 6
Select Case i
Case 1
Rows(i).RowHeight = 132.75
Case 2
Rows(i).RowHeight = 20.25
Case 3
Rows(i).RowHeight = 15.75
Case 4
Rows(i).RowHeight = 19.5
Case 5
Rows(i).RowHeight = 19.5
Case 6
Rows(i).RowHeight = 38.25
End Select
Next i

End Sub


Sub Action_Tidy_Up()
'
' Macro to remove any extraneous spaces in cells within the Action
' columns to highlight the need to complete relevant actions properly

Dim arrData() As Variant
Dim arrReturnData() As Variant
Dim rng As Excel.Range
Dim lRows As Long
Dim lCols As Long
Dim i As Long, j As Long

Range("y7:ab10000").Select

lRows = Selection.Rows.Count
lCols = Selection.Columns.Count

ReDim arrData(1 To lRows, 1 To lCols)
ReDim arrReturnData(1 To lRows, 1 To lCols)

Set rng = Selection
arrData = rng.Value

For j = 1 To lCols
For i = 1 To lRows
If Trim(arrData(i, j)) = "" Then
arrReturnData(i, j) = Trim(arrData(i, j))
Else
arrReturnData(i, j) = arrData(i, j)
End If
Next i
Next j

rng.Value = arrReturnData

Set rng = Nothing

End Sub


Sub Print_Report()
'
' Macro to prepare rows for printing by ensure only rows containing
data
' are visible and then print one copy


With ActiveSheet.PageSetup '
Set Page Setup
.PrintTitleRows = "$2:$6"
.PrintTitleColumns = ""
.PrintArea = "$A:$AB"
.Orientation = xlLandscape
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = False

End With

Rows("1:1").Select
Selection.EntireRow.Hidden = True '
Hide control panel when printing

Selection.AutoFilter Field:=30, Criteria1:="x" '
Hide rows with no data

If Application.Dialogs(xlDialogPrinterSetup).Show Then
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True '
Print one copy

Else
End If

Selection.AutoFilter Field:=30 '
Show rows with no data

Rows("1:1").Select '
Reveal control panel
Selection.EntireRow.Hidden = False

End Sub


Sub Print_Summary()
'
' This macro prints a summary report that excludes the control and
action details
'

Call Row_Heights ' Macro to return heights of Rows 1-6 to their
preset heights

Call Action_Tidy_Up ' Macro to remove any extraneous spaces in
cells within the Action
' columns to highlight the need to complete
relevant actions properly


Rows("7:310").EntireRow.AutoFit

Rows("1:1").Select ' Hide control
panel when printing
Selection.EntireRow.Hidden = True
Columns("J:J").Select ' Hide Local Risk
Description
Selection.EntireColumn.Hidden = True
Selection.AutoFilter Field:=2, Criteria1:="<>" ' Filter data to
one line per risk

With ActiveSheet.PageSetup ' Set Page Setup
.PrintTitleRows = "$2:$6"
.PrintTitleColumns = ""
.PrintArea = "$A:$T"
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = False
End With

If Application.Dialogs(xlDialogPrinterSetup).Show Then
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True '
Print one copy

Else
End If

With ActiveSheet.PageSetup ' Reset Page Setup
to default
.PrintArea = "$A:$AB"
End With

Rows("1:1").Select ' Unhide control
panel when printing
Selection.EntireRow.Hidden = False
Columns("J:J").Select ' Unhide Local
Risk Description
Selection.EntireColumn.Hidden = False
Selection.AutoFilter Field:=2 ' Filter data to
show all rows


End Sub



Sub Overdue_Actions()
'
' Overdue Actions Macro
' Macro recorded 01/06/2009 by mike.magill
'

'

Call Row_Heights ' Macro to return heights of Rows 1-6 to their
preset heights

Call Action_Tidy_Up ' Macro to remove any extraneous spaces in
cells within the Action
' columns to highlight the need to complete
relevant actions properly

' Check the user wants to print the risk register


Columns("BM:CB").Select
Selection.EntireColumn.Hidden = False

If UserForm2.CheckBox1.Value Then
Columns("BQ:BQ").EntireColumn.Hidden = True
End If


Rows("7:310").EntireRow.AutoFit


Selection.AutoFilter Field:=64 ' Filter to show
just Overdue Actions
Selection.AutoFilter Field:=64, Criteria1:=Range("BL6")



With ActiveSheet.PageSetup '
Set Page Setup
.PrintTitleRows = "$2:$6"
.PrintTitleColumns = ""
.PrintArea = "$BM:$CB"
.Orientation = xlLandscape
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = False
End With

Rows("1:1").Select
Selection.EntireRow.Hidden = True '
Hide control panel when printing

If Application.Dialogs(xlDialogPrinterSetup).Show Then
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True '
Print one copy

Else
End If

Rows("1:1").Select '
Reveal control panel
Selection.EntireRow.Hidden = False

With ActiveSheet.PageSetup '
Set Page Setup
.PrintTitleRows = "$2:$6"
.PrintTitleColumns = ""
.PrintArea = "$A:$AB"
.Orientation = xlLandscape
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = False
End With

Selection.AutoFilter Field:=64 ' Filter to show
just Overdue Actions



' Reprotect the worksheet and end macro

Columns("BM:CB").Select
Selection.EntireColumn.Hidden = True

Range("i4").Select

End Sub
 
Add 'Application.ScreenUpdating = False' inside the macros that are
hiding columns, I don't believe the one you have in the Print_Options
macro is enough to cover all the functions called by the userform.

You might also want to turn off calculation by adding
'Application.Calculation = xlCalculationManual' at the beginning of
your procedures. Reset it to automatic by using
'Application.Calculation = xlCalculationAutomatic'.

You didn't take out the Select/Selection pairs in Print_Summary. i.e.
instead of

Rows("1:1").Select
Selection.EntireRow.Hidden = True

use this:

Rows("1:1").EntireRow.Hidden = True

and the next line becomes

Columns("J:J").AutoFilter Field:=2, Criteria1:="<>" ' Filter data to
one line per risk

You could clean up Action_Tidy_Up some more. Since the range is
hardcoded as Y7:AB10000, you don't need to select it first. i.e.

Sub Action_Tidy_Up()
'
' Macro to remove any extraneous spaces in cells within the Action
' columns to highlight the need to complete relevant actions properly

Dim arrData() As Variant
Dim arrReturnData() As Variant
Dim rng As Excel.Range
Dim lRows As Long
Dim lCols As Long
Dim i As Long, j As Long

lRows = Range("Y7:AB10000").Rows.Count
lCols = Range("Y7:AB10000").Columns.Count

ReDim arrData(1 To lRows, 1 To lCols)
ReDim arrReturnData(1 To lRows, 1 To lCols)

Set rng = Range("Y7:AB10000")
arrData = rng.Value

For j = 1 To lCols
For i = 1 To lRows
If Trim(arrData(i, j)) = "" Then
arrReturnData(i, j) = Trim(arrData(i, j))
Else
arrReturnData(i, j) = arrData(i, j)
End If
Next i
Next j

rng.Value = arrReturnData

End Sub

Adding timers to your code can also help with debugging. Inside each
function, declare two Single variables like this:

Dim StartTime As Single
Dim EndTime As Single

Then at the start of each function, before any other statements
execute, put the following:

StartTime = Timer

At the end of the function, after all other statements have executed,
put the following:

EndTime = Timer
Debug.Print ("Macro: " & (EndTime - StartTime) & " seconds.")

Put the name of the current function inside the first set of double
quotes. i.e.

Debug.Print ("Macro: Print_Options " & (EndTime - StartTime) & "
seconds.")

Run your code and check the Immediate Window. Now you'll be able to
check which function takes the longest to execute, and focus your
efforts there.

Finally, check out websites like http://www.decisionmodels.com/optspeedd.htm
which offer more tips on finding and fixing bottlenecks.

--JP
 
Back
Top