VBA running VERY slow

[stuart_bisset]

Hi folks

I hope that I am not taking liberties here but the following code which
I have attached to custom dialog box is used so that the user can set
some specific headers and footers on approximately 37 sheets all at
once. The problem is it takes AGES and I'm looking for some advice on
how to quicken up my code. Like I say the only objective is to cycle
through each of these sheets, set the headers & footers to "" then
replace "" with the specified text if the check box on the user form
has been checked. The code is as follows:

*** loads up the user form ***
Sub GoHeader()
frmHeaders.Show
End Sub

*** THIS IS THE OK BUTTON ON THE USER FORM ***
Private Sub CommandButton1_Click()
GetHeaderValues
Unload frmHeaders
HeaderOptions
End Sub

*** THIS GRABS THE USER FORM VALUES ***
Sub GetHeaderValues()

Dim frm As UserForm
Set frm = frmHeaders

gboocb32 = frm.cb32.Value
gboocb33 = frm.cb33.Value
gboocb34 = frm.cb34.Value

End Sub


*** THIS CYCLES THROUGH EACH SHEET ***
Sub HeaderOptions()

Dim frm As UserForm
Dim CurrCell As Range
Dim CurrSheet As String
Dim xloop As Double
Dim yLoop As Double
Dim sht As String
Dim NumUnits As Long
Dim UnitNumber As Long
Dim LoopNumber As Long


Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Application.StatusBar = "Please wait whilst headers and footers are
setup..."
LoopNumber = Application.Names("sysListWorkSheets").RefersToRange.Count
NumUnits = Application.Names("sysUnitList").RefersToRange.Count - 2

''' records the cell currently selected by the user

CurrSheet = ActiveSheet.Name
Set CurrCell = Application.Selection


''' loops thru all sheets and sets headers & footers to nothing
''' then resets them to the correct values

'main sheets
For xloop = 1 To LoopNumber
sht = Range("sysListWorksheets").Item(xloop).Value
HeadersAndFooters (sht)
Next xloop

'business unit sheets
For xloop = 1 To NumUnits
UnitNumber = Range("sysunitnumbers").Item(xloop + 1)

For yLoop = 1 To 4
sht = "Unit " & UnitNumber & " " &
Range("sysListUnitSheets").Item(yLoop)
HeadersAndFooters (sht)
Next yLoop
Next xloop

Worksheets(CurrSheet).Activate
Range(CurrCell.Address).Select

CalculationSetUp
Application.StatusBar = False
Application.ScreenUpdating = True

End Sub


*** SETS THE HEADER AND FOOTER ***
Sub HeadersAndFooters(sht As String)

With Worksheets(sht).PageSetup
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""

If gboocb33 = True Then
.LeftHeader = "&""Arial,Bold""& Private and Confidential"
End If

If gboocb34 = True Then
.RightHeader = "&""Arial,Bold""& DRAFT - for discussion
purposes only"
End If

If gboocb34 = True Then
.LeftFooter = "&""Arial,Regular""& Prepared by Company
Name"
End If

End With
End Sub


***********************************

I would be very grateful for any comments & insights that you have for
me.

Cheers & TIA
Stuart

 

[Tom Ogilvy]

Change

Sub HeadersAndFooters(sht As String)


to not execute any code (comment it out) and then run the macro. Is it
significantly faster?

Then doing the page setup is the culprit. Pagesetup is known to be slow.

sometimes the xl4macro version of the code is faster. You can adapt the
below to modify only the attributes of interest:

From: John Green ([email protected])
Subject: Re: About PageSetup..
Newsgroups: microsoft.public.excel.programming
View complete thread (10 articles)
Date: 2001-01-22 12:57:23 PST




PageSetup in VBA has always been a painfully slow process. If you can't
avoid having
to set these parameters, you can use the Excel 4 macro function, PAGE.SETUP
to carry
out most of the PageSetup operations much more quickly. The following two
macros are
almost equivalent, and should give you the clues you need to start using
PAGE.SETUP.
You can download a full description of all the Excel 4 macro functions from
Microsoft's web site:

Sub PS()
ActiveSheet.DisplayPageBreaks = False
With ActiveSheet.PageSetup
.LeftHeader = "My Company"
.CenterHeader = ""
.RightHeader = "&D / &T"
.LeftFooter = "Highly Confidential and Proprietary"
.CenterFooter = ""
.RightFooter = "Finance"
.LeftMargin = Application.InchesToPoints(0.54)
.RightMargin = Application.InchesToPoints(0.3)
.TopMargin = Application.InchesToPoints(0.4)
.BottomMargin = Application.InchesToPoints(0.36)
.HeaderMargin = Application.InchesToPoints(0.22)
.FooterMargin = Application.InchesToPoints(0.17)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
' .PrintQuality = 600 ' does not work with all the printers
.CenterHorizontally = True
.CenterVertically = True
.Orientation = xlLandscape
.Draft = False
.PaperSize = xlPaperLetter
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 1
End With
End Sub

Sub PS4()
head = """&LMy Company&R&D / &T"""
foot = """&LHighly Confidential and Proprietary&RFinance"""
pLeft = 0.54
pRight = 0.3
Top = 0.4
bot = 0.36
head_margin = 0.22
foot_margin = 0.17
hdng = False
grid = False
notes = False
quality = ""
h_cntr = False
v_cntr = False
orient = 2
Draft = False
paper_size = 1
pg_num = """Auto"""
pg_order = 1
bw_cells = False
pscale = True
pSetUp = "PAGE.SETUP(" & head & "," & foot & "," & pLeft & "," & pRight &
","
pSetUp = pSetUp & Top & "," & bot & "," & hdng & "," & grid & "," & h_cntr
& ","
pSetUp = pSetUp & v_cntr & "," & orient & "," & paper_size & "," & pscale
& ","
pSetUp = pSetUp & pg_num & "," & pg_order & "," & bw_cells & "," & quality
& ","
pSetUp = pSetUp & head_margin & "," & foot_margin & "," & notes & "," &
Draft & ")"

Application.ExecuteExcel4Macro pSetUp
End Sub

John Green (Excel MVP)
Sydney
Australia