Solved: VBA to set print area on several worksheets to 1 wide and N tall + Landscape

[alu]

Hi, I have a v. large spreadsheet I apply some macros to it to format it all of which are within the same module.

Now I have several worksheets. What I am trying to do is add some code to the module that will make the page setup for all worksheets go to 1 wide by infinite tall and all in landscape.

I have this which works but has to be run in each individual worksheet. which is a bit of a fiddle.

Thanks all!!

Sub FitToPage()
'
' FitToPage Macro
' Macro recorded 13/06/2007 by XAZZ'
'
With ActiveSheet.PageSetup
.PrintTitleRows = ""
.PrintTitleColumns = ""
End With
ActiveSheet.PageSetup.PrintArea = ""
With ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
.LeftMargin = Application.InchesToPoints(0.15748031496063)
.RightMargin = Application.InchesToPoints(0.15748031496063)
.TopMargin = Application.InchesToPoints(0.78740157480315)
.BottomMargin = Application.InchesToPoints(0.78740157480315)
.HeaderMargin = Application.InchesToPoints(0.31496062992126)
.FooterMargin = Application.InchesToPoints(0.31496062992126)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.PrintQuality = 600
.CenterHorizontally = False
.CenterVertically = False
.Orientation = xlLandscape
.Draft = False
.PaperSize = xlPaperA4
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = False
.PrintErrors = xlPrintErrorsDisplayed
End With
ActiveWindow.SmallScroll Down:=-3
End Sub

[lucas]

Try this:
[VBA]
Option Explicit
Sub SetupAllSheets()
'
Dim M As Long, N As Long, Firstsht As Long, Lastsht As Long, Sheet As Object
'
Lastsht = Sheets.Count
M = 0: N = Lastsht
'
For Each Sheet In Sheets
If Not Sheet.Visible Then N = N - 1
If Sheet.Visible And Sheet.Type = xlWorksheet Then
If WorksheetFunction.CountA(Sheet.UsedRange) = 0 Then
N = N - 1
End If
End If
Next
'
For Firstsht = 1 To Lastsht
'
If Sheets(Firstsht).Visible = True Then
'
If Not TypeName(Sheets(Firstsht)) = "Chart" Then
If WorksheetFunction.CountA(Sheets(Firstsht).UsedRange) <> 0 Then
M = M + 1
GoSub DoPrint
End If
Else 'else it's a chart
M = M + 1
GoSub DoPrint
End If
'
End If
'
Next 'Firstsht
Exit Sub
DoPrint:
With Sheets(Firstsht).PageSetup
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
.LeftMargin = Application.InchesToPoints(0.15748031496063)
.RightMargin = Application.InchesToPoints(0.15748031496063)
.TopMargin = Application.InchesToPoints(0.78740157480315)
.BottomMargin = Application.InchesToPoints(0.78740157480315)
.HeaderMargin = Application.InchesToPoints(0.31496062992126)
.FooterMargin = Application.InchesToPoints(0.31496062992126)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.PrintQuality = 600
.CenterHorizontally = False
.CenterVertically = False
.Orientation = xlLandscape
.Draft = False
.PaperSize = xlPaperA4
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = False
.PrintErrors = xlPrintErrorsDisplayed
End With
With Application
.EnableEvents = False
' Sheets(Firstsht).PrintPreview '.PrintOut
.EnableEvents = True
End With
Return
End Sub[/VBA]

[alu]

Thanks Lucas, worked very well. Thankyou!!

[lucas]

In case your looking for syntax for headers/footers. Here is a list put together by Aaron

'header/footer syntax
'Font Change:
'A font Change is an ampersand, then a quote, the font name,
'then the font style, then another quote.
'Font Style Values can be: "Bold, Italic, BoldItalic, Regular"
'Example: &"Arial,Bold"
'myStr = "&""Arial,Bold"""
'Standalone Sytle Tags:
'&U = Underline
'&E = Double Underline
'&S = Strike Through
'&Y = SubScript
'&X = Superscipt
'Function Tags():
'&P = Page
'&N = Pages
'&D = Date
'&T = Time
'&Z = Path
'&F = File
'&A = Tab
'
'*Notes:
'Style Tags my be "closed" by adding another tag of the same type.
'(ex "Normal &U Undeline&U Normal")
'The total character count for all three segments of the header
'may not exceed 255 characters. The same hold true of footers.
'There is a &G tag that is used as an image place holder.
'However you set an image via the HeaderPicture Properties
'and the tag is automatically inserted.

[alu]

Hi, I was using the above code for a while without any problems.

Now when I try to use it in a new workbook my machine just freezes and is unresponsive??

I am trying to achieve exactly the same goal of settting all sheets on a work book to 1 wide + n tall, with a set margin, footer and generall page setup stuff.

Is there another way? thanks all

[lucas]

Hi alu,
Could you post a workbook that this is occuring in as I just opened a new workbook and pasted the code from above in and ran it with no problem. What does your data look like? What is different in it than previous workbooks, etc.

[alu]

I just tried using your original code and it worked fine. It would seem I had cut a few things out to speed it up and commented over an important line.

Thanks again Lucas for the original code, I will put a little more thought into it next time!

cheers :-)