software

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(quot;HdrLenquot;) gt; c_intMaxHdrLen Then
MsgBox quot;Your Header exceeds 232 characters. Please go back to the header page and reduce the # of Charactersquot;
Cancel = True
Exit Sub
End If

Application.ScreenUpdating = False
For Each wkSht In ThisWorkbook.Worksheets
SetHeader wkSht
Next wkSht
Application.ScreenUpdating = True
End SubPrivate 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(quot;HdrLenquot;) gt; c_intMaxHdrLen Then
MsgBox quot;Your Header exceeds 232 characters. Please go back to the header page and reduce the # of Charactersquot;
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 1Code:
--------------------
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(quot;HeaderPagequot;)
Application.ScreenUpdating = False
'defines where the data is coming from on the header page and what the format is
lStr = quot;amp;8quot; amp; .Range(quot;K2quot;) amp; vbCr amp; .Range(quot;K3quot;) amp; vbCr amp; .Range(quot;K4quot;) amp; vbCr amp; .Range(quot;K5quot;)
rStr = quot;amp;8quot; amp; .Range(quot;M2quot;) amp; vbCr amp; .Range(quot;M3quot;) amp; vbCr amp; .Range(quot;M4quot;) amp; vbCr amp; .Range(quot;M5quot;) amp; vbCr amp; .Range(quot;M6quot;)
dStr = quot;amp;8quot; amp; .Range(quot;M11quot;)
eStr = quot;amp;6quot; amp; .Range(quot;W1quot;) amp; vbCr amp; .Range(quot;W2quot;) amp; vbCr amp; .Range(quot;W3quot;) amp; vbCr amp; .Range(quot;W4quot;)
tStr = quot;Page quot; amp; quot;amp;Pquot; amp; quot; of quot; amp; quot;amp;Nquot;
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(quot;Instructionsquot;).Visible = False

End With
End Sub
----------------------
retseort
------------------------------------------------------------------------
retseort's Profile: www.excelforum.com/member.php...oamp;userid=24690
View this thread: www.excelforum.com/showthread...hreadid=500187Couple of ideas...

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

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 SubIn a regular code module:

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

Public Sub LoadHeaderFooterArray()
Dim i As Long
With Worksheets(quot;HeaderPagequot;)
sHeaderFooterArray(1) = quot;amp;8 quot; amp; .Range(quot;K2quot;).Text amp; _
vbCr amp; .Range(quot;K3quot;).Text amp; vbCr amp; _
.Range(quot;K4quot;).Text amp; vbCr amp; .Range(quot;K5quot;).Text
sHeaderFooterArray(2) = quot;amp;8 quot; amp; .Range(quot;M2quot;).Text amp; _
vbCr amp; .Range(quot;M3quot;).Text amp; vbCr amp; _
.Range(quot;M4quot;).Text amp; vbCr amp; .Range(quot;M5quot;).Text amp; _
vbCr amp; .Range(quot;M6quot;).Text
sHeaderFooterArray(3) = quot;amp;8 quot; amp; .Range(quot;M11quot;).Text
sHeaderFooterArray(4) = quot;quot;
sHeaderFooterArray(5) = quot;amp;6 quot; amp; .Range(quot;W1quot;).Text amp; _
vbCr amp; .Range(quot;W2quot;).Text amp; vbCr amp; _
.Range(quot;W3quot;).Text amp; vbCr amp; .Range(quot;W4quot;).Text
sHeaderFooterArray(6) = quot;Page amp;P of amp;Nquot;
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(quot;HdrLenquot;) gt; c_intMaxHdrLen Then
MsgBox Replace(c_strMsg, quot;$$quot;, 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(quot;Instructionsquot;).Visible = False
wkOld.Activate
rOld.Select
Application.ScreenUpdating = True
SetHeaders = False
End If
ErrResume:
On Error GoTo 0
End Function

In article gt;,
retseort gt;
wrote:

gt; Forgive because this will be a lot of code. The overall point to all of
gt; this code is to update the header and footer based upon entires made on
gt; the HeaderPage worksheet. The code pulls the entries made and populates
gt; the header and footer on all worksheets with in the workbook. The issue
gt; is that it has to loop through each worksheet when activated and can
gt; take some time to complete. Is there anything I can do to this to speed
gt; it up?
gt;
gt; The code below is found in two parts.
gt;
gt; The following code is found in ThisWorkbook:
gt;
gt;
gt; Code:
gt; --------------------
gt; Private Sub Workbook_BeforePrint(Cancel As Boolean)
gt; 'this code repeats the header and footer code for each worksheet
gt; 'this code drives the warning for the user if they exceed the number of
gt; allowable H/F bytes
gt; 'this code is triggered every time a user tries to print or print preview
gt; Const c_intMaxHdrLen As Integer = 232
gt;
gt; Dim wkSht As Worksheet
gt;
gt; If Range(quot;HdrLenquot;) gt; c_intMaxHdrLen Then
gt; MsgBox quot;Your Header exceeds 232 characters. Please go back to the header
gt; page and reduce the # of Charactersquot;
gt; Cancel = True
gt; Exit Sub
gt; End If
gt;
gt; Application.ScreenUpdating = False
gt; For Each wkSht In ThisWorkbook.Worksheets
gt; SetHeader wkSht
gt; Next wkSht
gt; Application.ScreenUpdating = True
gt; End Sub
gt;
gt;
gt; Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As
gt; Boolean)
gt; 'this code repeats the header and footer code for each worksheet
gt; 'this code drives the warning for the user if they exceed the number of
gt; allowable H/F bytes
gt; 'this code is triggered every time a user tries to save
gt; Const c_intMaxHdrLen As Integer = 232
gt;
gt; Dim wkSht As Worksheet
gt;
gt; If Range(quot;HdrLenquot;) gt; c_intMaxHdrLen Then
gt; MsgBox quot;Your Header exceeds 232 characters. Please go back to the header
gt; page and reduce the # of Charactersquot;
gt; Cancel = True
gt; Exit Sub
gt; End If
gt;
gt; Application.ScreenUpdating = False
gt; For Each wkSht In ThisWorkbook.Worksheets
gt; SetHeader wkSht
gt; Next wkSht
gt; Application.ScreenUpdating = True
gt; End Sub
gt; --------------------
gt;
gt;
gt; The next code is found in Module 1
gt;
gt;
gt; Code:
gt; --------------------
gt; Sub SetHeader(Sh As Worksheet)
gt; ' this code takes data from the header page
gt; 'and populates it to the header and footer
gt; Dim lStr As String
gt; Dim rStr As String
gt; Dim dStr As String
gt; Dim eStr As String
gt; Dim tStr As String
gt;
gt; With Worksheets(quot;HeaderPagequot;)
gt; Application.ScreenUpdating = False
gt; 'defines where the data is coming from on the header page and what the
gt; format is
gt; lStr = quot;amp;8quot; amp; .Range(quot;K2quot;) amp; vbCr amp; .Range(quot;K3quot;) amp; vbCr amp; .Range(quot;K4quot;) amp;
gt; vbCr amp; .Range(quot;K5quot;)
gt; rStr = quot;amp;8quot; amp; .Range(quot;M2quot;) amp; vbCr amp; .Range(quot;M3quot;) amp; vbCr amp; .Range(quot;M4quot;) amp;
gt; vbCr amp; .Range(quot;M5quot;) amp; vbCr amp; .Range(quot;M6quot;)
gt; dStr = quot;amp;8quot; amp; .Range(quot;M11quot;)
gt; eStr = quot;amp;6quot; amp; .Range(quot;W1quot;) amp; vbCr amp; .Range(quot;W2quot;) amp; vbCr amp; .Range(quot;W3quot;) amp;
gt; vbCr amp; .Range(quot;W4quot;)
gt; tStr = quot;Page quot; amp; quot;amp;Pquot; amp; quot; of quot; amp; quot;amp;Nquot;
gt; End With
gt;
gt; With Sh.PageSetup
gt; .LeftHeader = lStr
gt; .CenterHeader = dStr
gt; .RightHeader = rStr
gt; .CenterFooter = eStr
gt; .RightFooter = tStr
gt; End With
gt;
gt; With ActiveSheet.PageSetup
gt; 'resets the top and bottom margins to accomodate the new header
gt; .TopMargin = Application.InchesToPoints(1.24)
gt; .BottomMargin = Application.InchesToPoints(1)
gt; Sheets(quot;Instructionsquot;).Visible = False
gt;
gt; End With
gt; End Sub
gt; --------------------


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

PageSetupXL4M LeftHead:=sHeaderFooterArray(1), _--
retseort
------------------------------------------------------------------------
retseort's Profile: www.excelforum.com/member.php...oamp;userid=24690
View this thread: www.excelforum.com/showthread...hreadid=500187See the link in (1) in my answer.

In article gt;,
retseort gt; wrote:

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