Help, need to speed up this macro

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:

Please Login or Register  to view this content.

The next code is found in Module 1

Please Login or Register  to view this content.

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

In article <retseort.21h8ko_1136994001.9448@excelforum-nospam.com>,
retseort <retseort.21h8ko_1136994001.9448@excelforum-nospam.com>
wrote:

> 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
> --------------------

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

PageSetupXL4M LeftHead:=sHeaderFooterArray(1), _

See the link in (1) in my answer.

In article <retseort.21hrjy_1137018601.303@excelforum-nospam.com>,
retseort <retseort.21hrjy_1137018601.303@excelforum-nospam.com> wrote:

> Thanks, I get a Compile Error Sub or Function Not defined at this point
> in the code:
>
> PageSetupXL4M LeftHead:=sHeaderFooterArray(1), _