FitToPages Problem

Mozzz · Jun 25, 2011

Hi! I'vo got an Excel sheet that I'd like to print 'properly' from vba code.
It must be 1 A4 wide (portrait) and contains many manual PageBreaks.
Here is my idea: I first set the PageSetup that way
PageSetup.zoom=false
PageSetup.FitToPagesWide=1
PageSetup.FitToPagesWide=50
(for example), so a zoom factor is calculated for the width to be correct
and the sheet fits to 1 page wide.
Unfortunately, I can't print that way, because in this mode, the manual
PageBreaks are ignored, so I have to set it back to zoom mode, so I'd like
to switch back to
PageSetup.zoom = x
where x would be the previously calculated zoom factor (in the FitToPage
mode), for example 70%

My problem is that I don't know where to read the value of the calculated
zoom factor (x)
Could someone help me ? (PageSetup.zoom stays to false, not to 70)
Maybe I could also calculate it myself ?

Thanks a lot!

Mozzz

p45cal · Jun 26, 2011

Curious this, this exact same question has been posed in 2006 and 2009:
http://www.pcreview.co.uk/forums/get-zoom-factor-after-fittopageswide-t2433340.html
and
http://www.sqldrill.com/excel/programming-vba-vb-c-etc/329638-fittopageswide.html
Is this a test question or something?

Anyway the various responses might give you what you need though Andy Pope gave this one here:

Code:

Sub X()
Application.ExecuteExcel4Macro "PAGE.SETUP(,,,,,,,,,,,,{1,#N/A})"
Application.ExecuteExcel4Macro "PAGE.SETUP(,,,,,,,,,,,,{#N/A,#N/A})"
MsgBox "Zoom factor is " & ActiveSheet.PageSetup.Zoom
End Sub

Mozzz · Jun 26, 2011

Window 7.0 Office 2010
When I searched for the answer his post came up but his answers did not resolve my problem. So to save a little time I just copy pasted his questions. I needed to capture the zoom value. I did not realize that I could insert Page Breaks while I was in the FitToPageWide mode, but I can so I guess my question was answered. Tom Urtis posted a great post that gets the zoom to the msgbox but I was wanting to capture it. (No longer necessary)

I am having problems with PageSetup. Left Header, Center and Right
Here is my code (all unlisted pagesetup are set to Default), and here is what I get.

Code:

  TopRow = ActiveCell.Address
    BottomRow = ActiveCell.SpecialCells(xlCellTypeLastCell).Address
    LastRow = Range(BottomRow).Cells(1, -1).Address
    Application.PrintCommunication = False
    With ActiveSheet.PageSetup
        .PrintTitleRows = "$1:$1"
        .PrintTitleColumns = ""
    End With
    Application.PrintCommunication = True
    With ActiveSheet
            .PageSetup.PrintArea = .Range(TopRow, LastRow).Address
    End With
    Application.PrintCommunication = False
    With ActiveSheet.PageSetup
        .LeftHeader = "&""Arial,Bold Italic""&16Wallace International Trucks Inc"
        .CenterHeader = "&""Arial,Bold""&14New / Used Inventory Details"
        .RightHeader = "&A"
        .LeftFooter = ""
        .CenterFooter = "Page &P of &N"

Left Header :Wallace International Trucks
Center Header: New / Used Inventory Det
Right Header : Is blank, nothing there.

Now that I think about it I probably should show all my code since when I just run this part it works.

Here it is:

Code:

Sub SlsInvSheet()
'
' Builds Inv Sheet for Salesman
'
'
    FinalRow = Cells(Rows.Count, 2).End(xlUp).Row
    
    Range("G1").ColumnWidth = 10
    Columns("H:R").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
'   SET COLUMN TITLES
    Range("C1:R1").Value = Array("VIN", "MAKE", "MODEL", "YR", _
        "WB", "ENGINE", "HP", "TRANS", "FA", "RA", _
        "RATIO", "GVW", "SUSP", "BRAKES", "WHEELS", "TIRES", "MILES", _
        "COLOR", "SOURCE")
'   INSERT COLUMN FOR DAYS TO TRACK AGEING
    Columns("W:W").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("W1").Select
    ActiveCell.FormulaR1C1 = "DAYS"
    Range("W2").Select
    ActiveCell.FormulaR1C1 = "=TODAY()-RC[-1]"
    Range("W2").NumberFormat = "0"
    Range("W2").Copy Destination:=Range("W3:W" & FinalRow)
    ActiveCell.Range("A1:A" & FinalRow).Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues
 '  Turn off Alerts
    Application.DisplayAlerts = False
 '  SPLIT OPTIONS TO INDIVIDUAL COLUMNS
    Range("G2:G" & FinalRow).TextToColumns Destination:=ActiveCell.Offset(0, -16), _
                DataType:=xlDelimited, Tab:=False, Other:=True, OtherChar:="*", FieldInfo:=Array(1, 1)
'   Turn On Alerts
    Application.DisplayAlerts = True
'   If New Vehicle SetProfile by Account Number, If Used Do Nothing
    
    For i = 2 To FinalRow
        Select Case Cells(i, 30).Value
        Case 13200
               ActiveCell.Offset(i - 2, -22).Formula = ActiveCell.Offset(i - 2, -18)
            
        Case 13300
            ActiveCell.Offset(i - 2, -22).Formula = "Nav-Othr"
            
        Case 13350
            ActiveCell.Offset(i - 2, -22).Formula = "UD"
            
        Case Else
            
        End Select
    Next i
    
'   Delete Entry Column
     ActiveCell.Offset(0, -1).Columns("A:A").EntireColumn.Delete Shift:=xlToLeft
     Cells(1, 23).Formula = "SOURCE"
     Cells(1, 27).Formula = "CNTL"
     Cells(1, 26).Formula = "PGM"
     
 '   Sort by New/Used by Profile By Stk #
  Cells(2, 29).Select
   ActiveSheet.Sort.SortFields.Clear
   ActiveSheet.Sort.SortFields.Add Key _
        :=ActiveCell.Range("A1:A" & FinalRow - 1), SortOn:=xlSortOnValues, Order:=xlAscending _
        , DataOption:=xlSortNormal
   ActiveSheet.Sort.SortFields.Add Key _
        :=ActiveCell.Offset(0, -28).Range("A1:A" & FinalRow), SortOn:=xlSortOnValues, Order:= _
        xlAscending, DataOption:=xlSortNormal
   ActiveSheet.Sort.SortFields.Add Key _
        :=ActiveCell.Offset(0, -27).Range("A1:A" & FinalRow), SortOn:=xlSortOnValues, Order:= _
        xlAscending, DataOption:=xlSortNormal
    With ActiveSheet.Sort
        .SetRange ActiveCell.Offset(0, -28).Range("A1:AC" & FinalRow)
        .Apply
    End With
    
 '   After first if Profile is the same delete it, When it changes insert row
    Cells(2, 1).Select
    Selection.Font.Bold = True
    
    
    For i = FinalRow To 1 Step -1
        If ActiveCell.Offset(i, 0) = ActiveCell.Offset(i - 1, 0) Then
            ActiveCell.Offset(i, 0).Clear
           
        
        Else
            
                ActiveCell.Offset(i, 0).Font.Bold = True
                ActiveCell.Offset(i, 0).Rows("1:1").EntireRow _
                .Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
                
                
        End If
    Next i
'   Move Profile Above Stock Number and Bold Face
    Cells(2, 1).Select
    
    For i = 2 To FinalRow
    
        If Cells(i, 1) <> "" Then
            Cells(i, 1).Rows("1:1").EntireRow _
                .Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
            Cells(i + 1, 1).Cut Destination:=Cells(i, 2)
                With Cells(i, 2).Font
                    .FontStyle = "Bold"
                    .Size = 14
                End With
        End If
    Next i
    
    
'   AutoFit Columns
    ActiveCell.Offset(0, 1).Columns("A:AA").EntireColumn.Select
    ActiveCell.Columns("A:AA").EntireColumn.EntireColumn.AutoFit
    
'   Center Columns
    Range("B1:AB" & FinalRow).HorizontalAlignment = xlCenter
       
   
    
'  Add Gridlines
    With Selection.Borders
        .LineStyle = xlContinuous
        .Weight = xlThin
        
    End With
'   Round CONTROL
   Cells(1, 27).Range("A1:A" & FinalRow).NumberFormat = "0"
   
'   Left Justify Profile Names
    
    Cells(2, 2).Select
    EndRow = False
    
    Do While CountRow < FinalRow
    
        For i = 2 To FinalRow
            CountRow = CountRow + 1
            If Cells(i, 2).Font.Size = 14 Then
                Cells(i, 2).HorizontalAlignment = xlLeft
                
            End If
        Next i
    Loop
    
    TopRow = ActiveCell.Address
    BottomRow = ActiveCell.SpecialCells(xlCellTypeLastCell).Address
    LastRow = Range(BottomRow).Cells(1, -1).Address
    Application.PrintCommunication = False
    With ActiveSheet.PageSetup
        .PrintTitleRows = "$1:$1"
        .PrintTitleColumns = ""
    End With
    Application.PrintCommunication = True
    With ActiveSheet
            .PageSetup.PrintArea = .Range(TopRow, LastRow).Address
    End With
    Application.PrintCommunication = False
    With ActiveSheet.PageSetup
        .LeftHeader = "&""Arial,Bold Italic""&16Wallace International Trucks Inc"
        .CenterHeader = "&""Arial,Bold""&14New / Used Inventory Details"
        .RightHeader = "&A"
        .LeftFooter = ""
        .CenterFooter = "Page &P of &N"
        .RightFooter = ""
        .LeftMargin = Application.InchesToPoints(0.5)
        .RightMargin = Application.InchesToPoints(0.5)
        .TopMargin = Application.InchesToPoints(1)
        .BottomMargin = Application.InchesToPoints(1)
        .HeaderMargin = Application.InchesToPoints(0.5)
        .FooterMargin = Application.InchesToPoints(0.5)
        .PrintHeadings = False
        .PrintGridlines = False
        .PrintComments = xlPrintNoComments
        .PrintQuality = 600
        .CenterHorizontally = False
        .CenterVertically = False
        .Orientation = xlLandscape
        .Draft = False
        .PaperSize = xlPaperLegal
        .FirstPageNumber = xlAutomatic
        .Order = xlDownThenOver
        .BlackAndWhite = False
        .Zoom = False
        .FitToPagesWide = 1
        .FitToPagesTall = False
        .PrintErrors = xlPrintErrorsDisplayed
        .OddAndEvenPagesHeaderFooter = False
        .DifferentFirstPageHeaderFooter = False
        .ScaleWithDocHeaderFooter = True
        .AlignMarginsHeaderFooter = True
        .EvenPage.LeftHeader.Text = ""
        .EvenPage.CenterHeader.Text = ""
        .EvenPage.RightHeader.Text = ""
        .EvenPage.LeftFooter.Text = ""
        .EvenPage.CenterFooter.Text = ""
        .EvenPage.RightFooter.Text = ""
        .FirstPage.LeftHeader.Text = ""
        .FirstPage.CenterHeader.Text = ""
        .FirstPage.RightHeader.Text = ""
        .FirstPage.LeftFooter.Text = ""
        .FirstPage.CenterFooter.Text = ""
        .FirstPage.RightFooter.Text = ""
    End With
    Application.PrintCommunication = True
    
    '   Set Page Break at Beginning of Used
    Range("A1").Select
    
    LastColumn = Cells(1, Columns.Count).End(xlToLeft).Column
    IsUsed = False
    
    Do While IsUsed = False
            For i = 2 To FinalRow
            If Cells(i, LastColumn) > 13500 Then
                ActiveWindow.SelectedSheets.HPageBreaks.Add Before:=ActiveCell _
                    .Offset(i - 1, LastColumn)
                i = FinalRow
            End If
            
            Next i
        IsUsed = True
    Loop
End Sub

jasonb75 · Jun 26, 2011

Have a look at http://www.mrexcel.com/forum/showthread.php?t=542463

see if that helps.

For future reference, please use code tags when posting code to the forum, it makes it much easier for people to read.

p45cal · Jun 26, 2011

After some messing about, try, for that section of the code which sets the headers and footers setting:
Application.PrintCommunication = True

Mozzz · Jun 26, 2011

That is perfect. I think I will do a little research on the Print Communications Property (I assume it is a property)

As you can see I am pretty new to this. Never did VBA till about a month ago when I bought VBA and MAROS BY Bill Jelen.

To tag my code I just select it and hit the pound button. Thanks for your help,

Mozzz

jcbarte · Mar 21, 2019

HI there
I'm new to this forum and VBA - I am using MS Office Professional 2013 - Excel
I have a workbook with about 60 sheets - I only want the sheets with the comma in the name to set up the page formatting etc. This is the code I have but when I preview it - it is not on one page wide - can anyone help?
Thanks

Code:

 Sub Pagesetup()
Dim ws As Worksheet
Set sourceSheet = ActiveSheet

For Each ws In Worksheets
    ws.Activate
    If InStr(1, ws.Name, ",") > 0 Then
        Application.PrintCommunication = True
        Zoom = False
        PaperSize = xlPaperLetter
        Orientation = xlPortrait
        LeftMargin = Application.CentimetersToPoints(0.5)
        RightMargin = Application.CentimetersToPoints(0.5)
        TopMargin = Application.CentimetersToPoints(0.5)
        BottomMargin = Application.CentimetersToPoints(0.5)
        HeaderMargin = Application.CentimetersToPoints(0)
        FooterMargin = Application.CentimetersToPoints(0)
        FitToPagesWide = 1
        FitToPagesTall = False
        
    End If
Next

Application.DisplayAlerts = True
Sheets("WIP-Finance").Select
End Sub

RoryA · Mar 21, 2019

Welcome to the forum.

In future please post your question as a new thread unless it's directly related to the solution provided in an old one (which this isn't).

Your code is just assigning values to some undeclared variables that you never use. You should be accessing properties of the sheets' PageSetup like this:

Code:

 Sub Pagesetup()
Dim ws As Worksheet
Set sourceSheet = ActiveSheet

For Each ws In Worksheets
    If InStr(1, ws.Name, ",") > 0 Then
        Application.PrintCommunication = True
        With ws.Pagesetup
            .Zoom = False
            .PaperSize = xlPaperLetter
            .Orientation = xlPortrait
            .LeftMargin = Application.CentimetersToPoints(0.5)
            .RightMargin = Application.CentimetersToPoints(0.5)
            .TopMargin = Application.CentimetersToPoints(0.5)
            .BottomMargin = Application.CentimetersToPoints(0.5)
            .HeaderMargin = Application.CentimetersToPoints(0)
            .FooterMargin = Application.CentimetersToPoints(0)
            .FitToPagesWide = 1
            .FitToPagesTall = False
        End With
    End If
Next

Application.DisplayAlerts = True
Sheets("WIP-Finance").Select
End Sub

FitToPages Problem

Mozzz

Board Regular

Excel Facts

p45cal

Well-known Member

Mozzz

Board Regular

jasonb75

Well-known Member

p45cal

Well-known Member

Mozzz

Board Regular

jcbarte

New Member

RoryA

MrExcel MVP, Moderator

Similar threads

Forum statistics

Share this page

FitToPages Problem

Board Regular

Excel Facts

Well-known Member

Board Regular

Well-known Member

Well-known Member

Board Regular

New Member

MrExcel MVP, Moderator

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock