Help, need to speed up this macro

[retseort]

Forgive because this will be a lot of code. The overall point to all of
this code is to update the header and footer based upon entires made on
the HeaderPage worksheet. The code pulls the entries made and populates
the header and footer on all worksheets with in the workbook. The issue
is that it has to loop through each worksheet when activated and can
take some time to complete. Is there anything I can do to this to speed
it up?

The code below is found in two parts.

The following code is found in ThisWorkbook:


Code:
--------------------
Private Sub Workbook_BeforePrint(Cancel As Boolean)
'this code repeats the header and footer code for each worksheet
'this code drives the warning for the user if they exceed the number of allowable H/F bytes
'this code is triggered every time a user tries to print or print preview
Const c_intMaxHdrLen As Integer = 232

Dim wkSht As Worksheet

If Range("HdrLen") > c_intMaxHdrLen Then
MsgBox "Your Header exceeds 232 characters. Please go back to the header page and reduce the # of Characters"
Cancel = True
Exit Sub
End If

Application.ScreenUpdating = False
For Each wkSht In ThisWorkbook.Worksheets
SetHeader wkSht
Next wkSht
Application.ScreenUpdating = True
End Sub


Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
'this code repeats the header and footer code for each worksheet
'this code drives the warning for the user if they exceed the number of allowable H/F bytes
'this code is triggered every time a user tries to save
Const c_intMaxHdrLen As Integer = 232

Dim wkSht As Worksheet

If Range("HdrLen") > c_intMaxHdrLen Then
MsgBox "Your Header exceeds 232 characters. Please go back to the header page and reduce the # of Characters"
Cancel = True
Exit Sub
End If

Application.ScreenUpdating = False
For Each wkSht In ThisWorkbook.Worksheets
SetHeader wkSht
Next wkSht
Application.ScreenUpdating = True
End Sub
--------------------


The next code is found in Module 1


Code:
--------------------
Sub SetHeader(Sh As Worksheet)
' this code takes data from the header page
'and populates it to the header and footer
Dim lStr As String
Dim rStr As String
Dim dStr As String
Dim eStr As String
Dim tStr As String

With Worksheets("HeaderPage")
Application.ScreenUpdating = False
'defines where the data is coming from on the header page and what the format is
lStr = "&8" & .Range("K2") & vbCr & .Range("K3") & vbCr & .Range("K4") & vbCr & .Range("K5")
rStr = "&8" & .Range("M2") & vbCr & .Range("M3") & vbCr & .Range("M4") & vbCr & .Range("M5") & vbCr & .Range("M6")
dStr = "&8" & .Range("M11")
eStr = "&6" & .Range("W1") & vbCr & .Range("W2") & vbCr & .Range("W3") & vbCr & .Range("W4")
tStr = "Page " & "&P" & " of " & "&N"
End With

With Sh.PageSetup
.LeftHeader = lStr
.CenterHeader = dStr
.RightHeader = rStr
.CenterFooter = eStr
.RightFooter = tStr
End With

With ActiveSheet.PageSetup
'resets the top and bottom margins to accomodate the new header
.TopMargin = Application.InchesToPoints(1.24)
.BottomMargin = Application.InchesToPoints(1)
Sheets("Instructions").Visible = False

End With
End Sub

 

[JE McGimpsey]

Couple of ideas...

1) Every access of a .PageSetup object property takes a long time. See

http://www.mcgimpsey.com/excel/udfs/pagesetup.html

for a way to set all the properties in each object at once. You'll have
to do it once per worksheet, but it should speed things up significantly.

2) Since the headers are all going to be the same, I'd think you could
calculate the strings only once per BeforePrint or BeforeSave. For
instance, here's how I might arrange it:

in the ThisWorkbook module:

Private Sub Workbook_BeforePrint(Cancel As Boolean)
Cancel = SetHeaders
End Sub

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, _
Cancel As Boolean)
Cancel = SetHeaders
End Sub


In a regular code module:

Const c_intMaxHdrLen As Integer = 232
Const c_strMsg As String = "Your header exceeds $$ characters. " & _
"Please go back to the header page and reduce the number " & _
"of characters."
Dim sHeaderFooterArray(1 To 6) As String

Public Sub LoadHeaderFooterArray()
Dim i As Long
With Worksheets("HeaderPage")
sHeaderFooterArray(1) = "&8 " & .Range("K2").Text & _
vbCr & .Range("K3").Text & vbCr & _
.Range("K4").Text & vbCr & .Range("K5").Text
sHeaderFooterArray(2) = "&8 " & .Range("M2").Text & _
vbCr & .Range("M3").Text & vbCr & _
.Range("M4").Text & vbCr & .Range("M5").Text & _
vbCr & .Range("M6").Text
sHeaderFooterArray(3) = "&8 " & .Range("M11").Text
sHeaderFooterArray(4) = ""
sHeaderFooterArray(5) = "&6 " & .Range("W1").Text & _
vbCr & .Range("W2").Text & vbCr & _
.Range("W3").Text & vbCr & .Range("W4").Text
sHeaderFooterArray(6) = "Page &P of &N"
End With
End Sub

Public Function SetHeaders() As Boolean
Dim wkSht As Worksheet
Dim wkOld As Worksheet
Dim rOld As Range

SetHeaders = True
On Error GoTo ErrResume
If Range("HdrLen") > c_intMaxHdrLen Then
MsgBox Replace(c_strMsg, "$$", c_intMaxHdrLen)
Else
LoadHeaderFooterArray
Application.ScreenUpdating = False
Set rOld = Selection
Set wkOld = ActiveSheet
For Each wkSht In ActiveWorkbook.Worksheets
wkSht.Activate
PageSetupXL4M LeftHead:=sHeaderFooterArray(1), _
CenterHead:=sHeaderFooterArray(2), _
RightHead:=sHeaderFooterArray(3), _
LeftFoot:=sHeaderFooterArray(4), _
CenterFoot:=sHeaderFooterArray(5), _
RightFoot:=sHeaderFooterArray(6), _
TopMarginInches:=Application.InchesToPoints(1.24), _
BottomMarginInches:=Application.InchesToPoints(1)
Next wkSht
Sheets("Instructions").Visible = False
wkOld.Activate
rOld.Select
Application.ScreenUpdating = True
SetHeaders = False
End If
ErrResume:
On Error GoTo 0
End Function

 

[retseort]

Thanks, I get a Compile Error Sub or Function Not defined at this point
in the code:

PageSetupXL4M LeftHead:=sHeaderFooterArray(1), _

 

[JE McGimpsey]

See the link in (1) in my answer.