MrRhodes2004
01-11-2007, 08:44 AM
Hey Group,
I have a sub that formats all of the sheets of a workbook. This is typically done by the user after the workbook has been written if they haven?t used a template.
First, the process is very slow and I have tried to speed it up with the use of turning off the screen updating and the automatic calculation. Is there a way to speed the process up?
Second, sometimes the user has formatted some of the sheets and doesn?t want all of the sheets reformatted. How do I have it create a pop-up with a list of the sheets in the workbook with checkboxes next to each for the user to designate which sheets to format?
Sub ProjHeadFoot()
''' - code to ask user to select which sheets will be formatted
Application.Calculation = xlManual
ActiveSheet.Select
Dim sProjNo, sUser As String
Dim ws As Worksheet
'ask user for project number
sProjNo = InputBox("Enter Project Number")
iexit sub if user doesn't enter project number
If sProjNo = "" Then Exit Sub
sUser = Application.UserName
Application.ScreenUpdating = False
''' - change the following code to format only requested sheets not all sheets
For Each ws In Worksheets
'reset the header and footer
With ws.PageSetup
.LeftHeader = "&8a"
.CenterHeader = "&8a"
.RightHeader = "&8a"
.LeftFooter = "&8a"
.CenterFooter = "&8a"
.RightFooter = "&8a"
.LeftMargin = Application.InchesToPoints(0.5)
.RightMargin = Application.InchesToPoints(0.5)
.TopMargin = Application.InchesToPoints(0.75)
.BottomMargin = Application.InchesToPoints(0.75)
.HeaderMargin = Application.InchesToPoints(0.5)
.FooterMargin = Application.InchesToPoints(0.5)
.PrintQuality = 600
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = 100
.PrintErrors = xlPrintErrorsDisplayed
End With
With ws.PageSetup
On Error GoTo ErrorExit
'picture information
.LeftHeaderPicture _
.Filename = "I:\proj\struct\Prog\XLS\logo.gif"
.LeftHeaderPicture.Height = 55.05
.LeftHeaderPicture.Width = 92.7
.LeftHeaderPicture.Brightness = 0#
.LeftHeaderPicture.Contrast = 0#
'places picture in header
.LeftHeader = "&G"
'header information
.CenterHeader = "&""Times New Roman,Bold""&11&A"
.RightHeader = "&8Project No: " & sProjNo
.LeftFooter = "&7&Z&F"
.CenterFooter = "&8&P of &N"
.RightFooter = "&8&D" & Chr(10) & sUser
End With
Next
Application.ScreenUpdating = True
Application.Calculation = xlAutomatic
Exit Sub
Application.ScreenUpdating = True
Application.Calculation = xlAutomatic
ErrorExit:
Dim Msg, Style, Title
Msg = "An error occured and a portion or all of the header/footer was not created." _
& Chr(10) & "This error may happen if an older version of Excel is being run."
Style = vbCritical
Title = "Header/Footer Creation Error!"
MsgBox Msg, Style, Title
End Sub
I have a sub that formats all of the sheets of a workbook. This is typically done by the user after the workbook has been written if they haven?t used a template.
First, the process is very slow and I have tried to speed it up with the use of turning off the screen updating and the automatic calculation. Is there a way to speed the process up?
Second, sometimes the user has formatted some of the sheets and doesn?t want all of the sheets reformatted. How do I have it create a pop-up with a list of the sheets in the workbook with checkboxes next to each for the user to designate which sheets to format?
Sub ProjHeadFoot()
''' - code to ask user to select which sheets will be formatted
Application.Calculation = xlManual
ActiveSheet.Select
Dim sProjNo, sUser As String
Dim ws As Worksheet
'ask user for project number
sProjNo = InputBox("Enter Project Number")
iexit sub if user doesn't enter project number
If sProjNo = "" Then Exit Sub
sUser = Application.UserName
Application.ScreenUpdating = False
''' - change the following code to format only requested sheets not all sheets
For Each ws In Worksheets
'reset the header and footer
With ws.PageSetup
.LeftHeader = "&8a"
.CenterHeader = "&8a"
.RightHeader = "&8a"
.LeftFooter = "&8a"
.CenterFooter = "&8a"
.RightFooter = "&8a"
.LeftMargin = Application.InchesToPoints(0.5)
.RightMargin = Application.InchesToPoints(0.5)
.TopMargin = Application.InchesToPoints(0.75)
.BottomMargin = Application.InchesToPoints(0.75)
.HeaderMargin = Application.InchesToPoints(0.5)
.FooterMargin = Application.InchesToPoints(0.5)
.PrintQuality = 600
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = 100
.PrintErrors = xlPrintErrorsDisplayed
End With
With ws.PageSetup
On Error GoTo ErrorExit
'picture information
.LeftHeaderPicture _
.Filename = "I:\proj\struct\Prog\XLS\logo.gif"
.LeftHeaderPicture.Height = 55.05
.LeftHeaderPicture.Width = 92.7
.LeftHeaderPicture.Brightness = 0#
.LeftHeaderPicture.Contrast = 0#
'places picture in header
.LeftHeader = "&G"
'header information
.CenterHeader = "&""Times New Roman,Bold""&11&A"
.RightHeader = "&8Project No: " & sProjNo
.LeftFooter = "&7&Z&F"
.CenterFooter = "&8&P of &N"
.RightFooter = "&8&D" & Chr(10) & sUser
End With
Next
Application.ScreenUpdating = True
Application.Calculation = xlAutomatic
Exit Sub
Application.ScreenUpdating = True
Application.Calculation = xlAutomatic
ErrorExit:
Dim Msg, Style, Title
Msg = "An error occured and a portion or all of the header/footer was not created." _
& Chr(10) & "This error may happen if an older version of Excel is being run."
Style = vbCritical
Title = "Header/Footer Creation Error!"
MsgBox Msg, Style, Title
End Sub