.pagesetup not working

[Phil1981]

Hi all,

I have the following code that allows our team leaders to update their team lists and it will create an action plan for everyone, hide the raw data sheets and print out the action plans.

My issue is that it is not printing on one page as required and well the code is running very slow. Any help or suggestions would be greatly appreciated.

Option Explicit
Sub CreateActionPlan()
Dim LR As Long
Dim i As Long
Dim mySheet As Object
 
Application.ScreenUpdating = False
 
With Sheets("Team List")
    LR = .Range("D" & Rows.Count).End(xlUp).Row
    For i = 3 To LR
 
'Copy blank action plan, create new WS and paste action plan in new sheet
        Sheet7.Select
        Range("$A$1:$W$61").Select
        Selection.Copy
        Sheet7.Select
        Sheets.Add
 
'Rename sheet from team list table
        ActiveSheet.Name = .Range("D" & i).Value
        ActiveSheet.Paste
            Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
 
'Set pagesetup options
        With ActiveSheet.PageSetup
            .PrintArea = "$A$1:$W$61"
            .LeftMargin = Application.InchesToPoints(0.15)
            .RightMargin = Application.InchesToPoints(0.15)
            .TopMargin = Application.InchesToPoints(0.15)
            .BottomMargin = Application.InchesToPoints(0.15)
            .HeaderMargin = Application.InchesToPoints(0.15)
            .FooterMargin = Application.InchesToPoints(0.15)
            .CenterHorizontally = True
            .CenterVertically = True
            .Orientation = xlPortrait
            .PaperSize = xlPaperLetter
            .FitToPagesWide = 1
            .FitToPagesTall = 1
            .PrintErrors = xlPrintErrorsDisplayed
        End With
 
'Insert agent information
        ActiveSheet.Range("E5") = .Range("d" & i).Value
        ActiveSheet.Range("E7") = .Range("e" & i).Value
        ActiveSheet.Range("E9") = .Range("D1").Value
        ActiveSheet.Range("M7") = .Range("f" & i).Value
    Next i
End With
    
Calculate
 
'Hide raw data sheets
        Sheet1.Visible = xlSheetVeryHidden
        Sheet2.Visible = xlSheetVeryHidden
        Sheet3.Visible = xlSheetVeryHidden
        Sheet4.Visible = xlSheetVeryHidden
        Sheet5.Visible = xlSheetVeryHidden
        Sheet6.Visible = xlSheetVeryHidden
        Sheet7.Visible = xlSheetVeryHidden

'Select all unhidden sheets and print    
    For Each mySheet In Sheets
        With mySheet
            If .Visible = True Then .Select Replace:=False
        End With
    Next mySheet
    ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True
 
'Unhide all sheets
        Sheet1.Visible = xlSheetVisible
        Sheet2.Visible = xlSheetVisible
        Sheet3.Visible = xlSheetVisible
        Sheet4.Visible = xlSheetVisible
        Sheet5.Visible = xlSheetVisible
        Sheet6.Visible = xlSheetVisible
        Sheet7.Visible = xlSheetVisible
        
    Application.ScreenUpdating = True
End Sub

 

[Richard Schollar]

You need to set Zoom to False before you fit to pageswide/tall:

With ActiveSheet.PageSetup
            .PrintArea = "$A$1:$W$61"
            .LeftMargin = Application.InchesToPoints(0.15)
            .RightMargin = Application.InchesToPoints(0.15)
            .TopMargin = Application.InchesToPoints(0.15)
            .BottomMargin = Application.InchesToPoints(0.15)
            .HeaderMargin = Application.InchesToPoints(0.15)
            .FooterMargin = Application.InchesToPoints(0.15)
            .CenterHorizontally = True
            .CenterVertically = True
            .Orientation = xlPortrait
            .PaperSize = xlPaperLetter
            .Zoom = False
            .FitToPagesWide = 1
            .FitToPagesTall = 1
            .PrintErrors = xlPrintErrorsDisplayed
        End With

 

[Phil1981]

ok perfect ... I can not believe I left that out =)