Sleeper: Setting print settings in VBA

[peacenik]

I have some code that creates a new sheet and sets up printing for landscape, sets the size and puts headings on the page. This part of the code seems to run incredibly slowly. Is this a known problem or is there something I can do to speed this up?

[Ken Puls]

Hi there,

Can you post the code you're using? If you generated it via the macro recorder, there will be a ton of stuff you can pull out.

Other questions..
-is screenupdating turned off?
-are you referring to the sheet explicitly, or using Activsheet?

Lots of questions without seeing the actual code you are working with. ;)

[peacenik]

I have turned off screen updating. Where possible I have referenced sheets rather than using activesheet. Where I have done, it is because it didnt work using references (although I may have slipped up occasionally). I do record, but I have stripped out lots of stuff that I didn't need. Perhaps there is more though. Thanks in advance for your help.


It is difficult to show it all because there are userforms involved as well but:



Public CWS, Contents, BOM As Worksheet
Public TotalRow, LastRow As Long
Public ERRTEXT As String
Public MacroUpdate As Boolean
Public ReplacePart As String

Sub SetDefaultValues()
Set BOM = Sheets("_Bill of Materials")
Set Contents = Sheets("Contents")
End Sub

Sub Menu_Create()
Dim myMnu As Object
On Error Resume Next
Menu_Delete
Set myMnu = CommandBars("worksheet menu bar").Controls. _
Add(Type:=msoControlPopup, Before:=9)
With myMnu
' The "&" denotes a shortcut key assignment (Alt+C in this case).
.Caption = "&Cub Campers"
End With
With CommandBars("Worksheet menu bar").Controls("&Cub Campers")
.Controls.Add(Type:=msoControlButton, Before:=1).Caption = "&About"
.Controls("&About").OnAction = "About"
.Controls.Add(Type:=msoControlButton, Before:=1).Caption = "S&How all"
.Controls("S&How all").OnAction = "ShowAll"
.Controls.Add(Type:=msoControlButton, Before:=1).Caption = "&Show Recent Changes"
.Controls("&Show Recent Changes").OnAction = "ShowRecentChanges"
.Controls.Add(Type:=msoControlButton, Before:=1).Caption = "&Delete Row <ctrl-d>"
.Controls("&Delete Row <ctrl-d>").OnAction = "DeleteRow"
.Controls.Add(Type:=msoControlButton, Before:=1).Caption = "&Insert Row <ctrl-i>"
.Controls("&Insert Row <ctrl-i>").OnAction = "InsertRow"
.Controls.Add(Type:=msoControlButton, Before:=1).Caption = "&Add a Product"
.Controls("&Add a Product").OnAction = "Add_Product"
.Controls.Add(Type:=msoControlButton, Before:=1).Caption = "&Delete Camper"
.Controls("&Delete Camper").OnAction = "Delete_Camper"
.Controls.Add(Type:=msoControlButton, Before:=1).Caption = "&Clone Camper"
.Controls("&Clone Camper").OnAction = "Clone_Camper"
.Controls.Add(Type:=msoControlButton, Before:=1).Caption = "&Add Camper"
.Controls("&Add Camper").OnAction = "CreateCamper"
End With
End Sub

Sub Menu_Delete()
On Error Resume Next
CommandBars("Worksheet menu bar").Controls("&Cub Campers").Delete
End Sub

Sub CreateContents()
' CreateContents Macro
' Macro recorded 07-06-2002 by Paul Sinclair
SetDefaultValues
Contents.Activate
startupdate
Contents.Range("b1:c999").Clear
With ActiveWindow
.DisplayGridlines = False
.DisplayHeadings = False
.DisplayWorkbookTabs = False
.DisplayFormulas = False
End With
For i = 1 To Sheets.Count
If Sheets(i).Name <> "Contents" And Sheets(i).Name <> "Template" Then
FindKeyPoints (Sheets(i).Name)
Contents.Range("B2").Offset(i, 0).Value = Sheets(i).Name
If TotalRow > 0 Then Contents.Range("B2").Offset(i, 1).Value = Sheets(i).Range("G" & LastRow).Value
End If
Next
Contents.Columns("B:C").Select
Selection.Sort Key1:=Range("B1"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Contents.Range("B1").Select
TargetRange = Range("B1:b40").Address
For Each cell In Range(TargetRange)
If cell.Value <> "" Then
cell.Select
HLSubaddress = "'" & cell.Value & "'!B1"
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:= _
HLSubaddress, TextToDisplay:=cell.Value
Else
ActiveWorkbook.Names.Add Name:="CamperList", RefersToR1C1:= _
"=Contents!R2C2:R" & cell.Row - 1 & "C2"
Exit For
End If
Next
endupdate
End Sub

Sub startupdate()
ActiveSheet.Unprotect
Application.ScreenUpdating = False
Application.DisplayAlerts = False
MacroUpdate = True
End Sub

Sub endupdate()
Application.DisplayAlerts = True
Application.ScreenUpdating = True
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, AllowFiltering:=True
MacroUpdate = False
End Sub
Sub About()
MsgBox ("This spreadsheet was developed by Paul Sinclair. For information about the spreadsheet or to hire me, email me on paul.sinclair@gmail.com")
End Sub

Sub SortbyCode()
SetDefaultValues
startupdate
BOM.Unprotect
BOM.Range("a4").Select
Selection.End(xlDown).Select
ActiveCell.Offset(0, 5).Select
Range("a4:" & ActiveCell.Address).Select
Selection.Sort Key1:=Range("A4"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Range("a4").Select
BOM.Protect DrawingObjects:=True, Contents:=True, AllowFiltering:=True
endupdate
End Sub
Sub SortbySupplier()
Range("a6").Select
Selection.End(xlDown).Select
ActiveCell.Offset(0, 50).Select
Range("a6:" & ActiveCell.Address).Select
Selection.Sort Key1:=Range("b6"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Range("a6").Select
End Sub

Sub FindKeyPoints(SheetName)
LastRow = 0
TotalRow = 0
Set CWS = Sheets(SheetName)
On Error Resume Next
For Each cell In CWS.Range("C2:C399")
If cell.Value = "Sub Total" Then
TotalRow = cell.Row
End If
If cell.Value = "Total" Then
LastRow = cell.Row
Exit For
End If
Next
End Sub

Sub insertrow()
startupdate
FindKeyPoints (ActiveSheet.Name)
If TotalRow > 0 Then
Rows(TotalRow & ":" & TotalRow).Select
Selection.Insert Shift:=xlDown
Range("B2:G2").Select
Selection.Copy
Range("B" & TotalRow).Activate
ActiveSheet.Paste
Range("F" & TotalRow).ClearContents
Range("G" & TotalRow + 1).Formula = "=sum(G2:G" & TotalRow & ")"
Range("a" & TotalRow).Activate
End If
endupdate
End Sub
Sub deleterow()
startupdate
FindKeyPoints (ActiveSheet.Name)
If ActiveCell.Row < TotalRow Then
ActiveCell.EntireRow.Select
Selection.Delete Shift:=xlUp
Range("A" & ActiveCell.Row).Select
End If
endupdate
End Sub

Sub CreateCamper()
startupdate
CamperName = InputBox("Enter Camper Name", "Camper Name")
If CamperName <> "" Then
Sheets("Template").Activate
Cells.Select
Selection.Copy
Sheets.Add
ActiveSheet.Paste
ActiveSheet.Name = CamperName
Range("A1").Select
Range("A2").Select
ActiveWindow.FreezePanes = True
Range("B7").Value = ActiveSheet.Name
Range("B7").Font.Bold = True
FindKeyPoints (ActiveSheet.Name)
setprint
CreateContents
End If
endupdate
End Sub

Sub Delete_Camper()
DeleteCamper.Show
End Sub

Sub Clone_Camper()
CreateContents
CloneCamper.Show
End Sub

Function CheckAddProduct()
CheckAddProduct = True
ERRTEXT = ""
If AddProduct.Code.Value = "" Then
ERRTEXT = ERRTEXT & "Enter a Code. "
CheckAddProduct = False
End If
If AddProduct.Company.Value = "" Then
ERRTEXT = ERRTEXT & "Enter a Company. "
CheckAddProduct = False
End If
If AddProduct.Description.Value = "" Then
ERRTEXT = ERRTEXT & "Enter a Description. "
CheckAddProduct = False
End If
If AddProduct.Unit.Value = "" Then
ERRTEXT = ERRTEXT & "Enter a Unit. "
CheckAddProduct = False
End If
If AddProduct.Price.Value = "" Then
ERRTEXT = ERRTEXT & "Enter a Price. "
CheckAddProduct = False
End If
End Function

Sub Add_Product()
SetDefaultValues
AddProduct.Show
End Sub

Sub ShowRecentChanges()
'ShowRecentChanges Macro
' Macro recorded 28-07-2005 by Paul Sinclair
DefaultDate = "1/" & Month(Now()) & "/" & Year(Now())
ChangedSince = Format(InputBox("Display changes since ...", "Recent Changes", DefaultDate), "dd/mm/yyyy")
SetDefaultValues
If ChangedSince <> "" Then
For Each cell In BOM.Range("a2:a1000")
If cell.Value = "" Then
LastRow = cell.Row
Exit For
End If
Next
BOM.Activate
startupdate
BOM.Range("A2:F" & LastRow).Select
Selection.AutoFilter Field:=6, Criteria1:=">=" & ChangedSince, Operator:=xlAnd
BOM.Range("F3").EntireColumn.Hidden = False
BOM.Range("A4").Select
endupdate
End If
End Sub

Sub showall()
On Error Resume Next
SetDefaultValues
startupdate
BOM.ShowAllData
BOM.Range("F3").EntireColumn.Hidden = True
BOM.Range("A4").Select
endupdate
End Sub


Sub setprint()
ActiveSheet.PageSetup.PrintArea = "$A$1:$G" & LastRow
With ActiveSheet.PageSetup
.CenterHeader = "&""Arial,Bold""&14&A Pricing Sheet"
.CenterFooter = "as at &D"
.Orientation = xlLandscape
.Draft = False
.PaperSize = xlPaperA4
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = 100
.PrintErrors = xlPrintErrorsDisplayed
End With
End Sub

Sub FixNA()
'FindKeyPoints (ActiveSheet.Name)
For Each cell In Range("b2:b399")
On Error GoTo ErrorHandler
Test = Len(cell.Value)
Next
Exit Sub
ErrorHandler:
Select Case Err.Number
Case 13
ReplacePart = Range("a" & cell.Row)
FixCode.InvalidCode.Caption = ReplacePart
FixCode.Show
Resume
End Select
End Sub



This is the code in the user form.


Private Sub CommandButton1_Click()
AddProduct.Hide
startupdate
CheckAddProduct
If CheckAddProduct = True Then
AddProduct.ERRDisplay.Visible = False
BOM.Activate
startupdate
BOM.Rows("10:10").Select
Selection.Insert Shift:=xlDown
BOM.Range("A10").Value = UCase(AddProduct.Code.Value)
BOM.Range("B10").Value = UCase(AddProduct.Company.Value)
BOM.Range("C10").Value = UCase(AddProduct.Description.Value)
BOM.Range("D10").Value = UCase(AddProduct.Unit.Value)
BOM.Range("E10").Value = AddProduct.Price.Value
SortbyCode
endupdate
Else
AddProduct.ERRDisplay.Caption = ERRTEXT
AddProduct.ERRDisplay.Visible = True
End If
If AddProduct.OptionButton1 = True Then
'Replace the product selected with the new one.
If AddProduct.PartReplaced <> "" Then
startupdate
For i = 1 To Sheets.Count
If Sheets(i).Name <> "_Bill of Materials" And Sheets(i).Name <> "Contents" Then
Sheets(i).Unprotect
Sheets(i).Activate
FindKeyPoints (Sheets(i).Name)
Sheets(i).Range("a2:a" & TotalRow - 1).Select
Selection.Replace What:=UCase(AddProduct.PartReplaced.Value), Replacement:=AddProduct.Code.Value, LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Sheets(i).Protect
End If
Next
endupdate
End If
Else
'Add the new product to the campers selected
For i = 0 To AddProduct.NewPartSelect.ListIndex
If AddProduct.NewPartSelect.Selected(i) = True Then
Sheets(Contents.Range("A2").Offset(i, 0).Value).Activate
insertrow
Range("A" & TotalRow).Value = AddProduct.Code
End If
Next
End If
BOM.Activate
AddProduct.Show
End Sub

Private Sub OptionButton1_Click()
AddProduct.ReplacingText.Visible = True
AddProduct.NewPartText.Visible = False
AddProduct.PartReplaced.Visible = True
AddProduct.NewPartSelect.Visible = False
End Sub

Private Sub OptionButton2_Click()
AddProduct.ReplacingText.Visible = False
AddProduct.NewPartText.Visible = True
AddProduct.PartReplaced.Visible = False
AddProduct.NewPartSelect.Visible = True
End Sub

[peacenik]

Sorry, Ken or anyone else who is interested, can anyone give me some suggestions. It is pretty obvious that the slowdown is with the setprint subroutine but I can't see anything that I can remove. Any ideas?

[Ken Puls]

My apologies for not responding sooner, and thanks for the reminder!

I took a quick look just at the SetPrint sub. Running it on a blank worksheet takes over 1 second on my machine (3.06GHz, 512MB Ram), which does seem slow to me. The only thing I can suggest is culling out anything else that you may not need in there. To my mind, every . takes a little longer to go.

I would make one change, I think. You should be able to pull the PrintArea inside the With Block:


Sub setprint()
With ActiveSheet.PageSetup
.PrintArea = "$A$1:$G" & LastRow
.CenterHeader = "&""Arial,Bold""&14&A Pricing Sheet"
.CenterFooter = "as at &D"
.Orientation = xlLandscape
.Draft = False
.PaperSize = xlPaperA4
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = 100
.PrintErrors = xlPrintErrorsDisplayed
End With
End Sub

Sorry I can't be more help. I seem to remember that PageSetup macros are a bit slow, but they shouldn't be overwhelming, either.

[peacenik]

Thanks Ken, I will make the change you suggest. I have found it slow in the past too, but in this case, each sheet is about 200 lines and it is agonisingly slow. Just doesn't make any sense to me.

Once again, thanks.

Paul.

[Ivan F Moala]

Print setup can be slow depending on a number of things.

I won't go into all of them but

A couple of things to try and speed things up
1) Don't display pagebreaks
.DisplayPageBreaks = False
2) Page setup code faster using
this method.



'// NB: If any of the Variables are set wrong you will
'// Get NO error BUT it won't setup as you want.
ExecuteExcel4Macro ( _
"Page.Setup(""Hello"",""Testing"",0.75,0.75,1,1,FALSE" & _
",FALSE,FALSE,FALSE,2,9,TRUE,100,1,FALSE,360,0.5,0.5,FALSE,FALSE)")
</pre>

Where:
head Hello
foot Testing
left 0.75
right 0.75
top 1
bot 1
hdng FALSE
grid FALSE
h_cntr FALSE
v_cntr FALSE
orient 2
paper_size 9
scale TRUE
pg_num 100
pg_order 1
bw_cells FALSE
quality 300
head_margin 0.5
foot_margin 0.5
notes FALSE
draft FALSE

[Ken Puls]

Thanks, Ivan! Alwasy appreciate your input! :thumb