Home |
Search |
Today's Posts |
#1
Posted to microsoft.public.excel.misc
|
|||
|
|||
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: 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 -------------------- -- retseort ------------------------------------------------------------------------ retseort's Profile: http://www.excelforum.com/member.php...o&userid=24690 View this thread: http://www.excelforum.com/showthread...hreadid=500187 |
#2
Posted to microsoft.public.excel.misc
|
|||
|
|||
Help, need to speed up this macro
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 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 -------------------- |
#3
Posted to microsoft.public.excel.misc
|
|||
|
|||
Help, need to speed up this macro
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: http://www.excelforum.com/member.php...o&userid=24690 View this thread: http://www.excelforum.com/showthread...hreadid=500187 |
#4
Posted to microsoft.public.excel.misc
|
|||
|
|||
Help, need to speed up this macro
See the link in (1) in my answer.
In article , retseort wrote: Thanks, I get a Compile Error Sub or Function Not defined at this point in the code: PageSetupXL4M LeftHead:=sHeaderFooterArray(1), _ |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
Search, Copy, Paste Macro in Excel | Excel Worksheet Functions | |||
Can T Get Macro To Run! | New Users to Excel | |||
Closing File Error | Excel Discussion (Misc queries) | |||
Speed up macro | Excel Discussion (Misc queries) | |||
Date macro | Excel Discussion (Misc queries) |