PDA

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



alu
06-13-2007, 07:39 AM
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
06-13-2007, 07:57 AM
Try this:

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

alu
06-13-2007, 08:16 AM
Thanks Lucas, worked very well. Thankyou!!

lucas
06-13-2007, 08:41 AM
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
09-12-2007, 04:47 AM
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 :think:

lucas
09-12-2007, 04:52 AM
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
09-12-2007, 05:19 AM
:doh: 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 :-)