Add in Fit to 1 Page on Print out

[Ibbo1978]

Hi,

I have the following code that I have copied from another sheet, however I need it to fit to one page, how do I update below please:

Sheets("Butchery Order").Range("B1:K225").ExportAsFixedFormat _
Type:=xlTypePDF, Filename:=strPrimalPlan, Quality:=xlQualityStandard, IncludeDocProperties:=True, _
IgnorePrintAreas:=False, OpenAfterPublish:=True

 

[Jack in the UK]

Hi Ibb01978

Does this do what you require, test and copy of your workbook first
Pagebreak will reflect the changes

Sub myFIT_TO_ONE_Page_PRINT()

Dim myZoom As Boolean
Dim iWidth As Long
Dim iHeight As Long
Dim TARGET_WS As Worksheet

myZoom = False
iWidth = 1
iHeight = 1


Set TARGET_WS = ActiveSheet
 With traget_WS.PageSetup

     .Zoom = False
     .FitToPagesWide = 1
     .FitToPagesTall = 1
End With


theEND:
Set TARGET_WS = Nothing
Exit Sub

End Sub

 

[Ibbo1978]

I think I actually just need the selection to reduce to fit 1 page in the PDF? is that possible?

 

[Jack in the UK]

Untested maybe closer to what you require
Regards

jiuk

 Const MyTitle As String = "Select Print Area"
 Const Message As String = "Please select a RANGE To PRINT"
 '# jiuk
 
Sub myPRINT_ONE_PAGE()

Dim myZoom As Boolean
Dim iWidth As Long
Dim iHeight As Long
Dim TARGET_WS As Worksheet
Dim myPRINT_RANGE As Range

myZoom = False
iWidth = 1
iHeight = 1

Set myTarget_Worksheet = ActiveSheet

On Error Resume Next
  
Set myPRINT_RANGE = Application.InputBox(Message, Title, , , , , , 8)

 On Error GoTo 0
 If myPRINT_RANGE Is Nothing Then
 MsgBox "Code will abort - nothing selected"
 Exit Sub
 End If

 With myTarget_Worksheet.PageSetup
 
 .Zoom = False
 .PrintArea = myPRINT_RANGE.Address
 .CenterHorizontally = True
 .CenterVertically = False
 .PrintTitleRows = ("$A$1:$k$1") ' jiuk - edit or omit as required
 .Orientation = xlPortrait ' jiuk - change as required
 .FitToPagesWide = iWidth
 .FitToPagesTall = iHeight
    
 End With
 
myTarget_Worksheet.PrintOut

theEND:
Set myTarget_Worksheet = Nothing

 End Sub

 

[Jack in the UK]

- or -

jiuk

 Const MyTitle As String = "Select Print Area"
 Const Message As String = "Please select a RANGE To PRINT"
 '# jiuk
 
Sub myPRINT_ONE_PAGE()

Dim myZoom As Boolean
Dim iWidth As Long
Dim iHeight As Long
Dim TARGET_WS As Worksheet
Dim myPRINT_RANGE As Range

myZoom = False
iWidth = 1
iHeight = 1

Set myTarget_Worksheet = ActiveSheet

On Error Resume Next
  
'Set myPRINT_RANGE = Application.InputBox(Message, Title, , , , , , 8)
'# B1:K225
Set myPRINT_RANGE = Range("B1:K225")

 On Error GoTo 0
 If myPRINT_RANGE Is Nothing Then
 MsgBox "Code will abort - nothing selected"
 Exit Sub
 End If

 With myTarget_Worksheet.PageSetup
 
 .Zoom = False
 .PrintArea = myPRINT_RANGE.Address
 .CenterHorizontally = True
 .CenterVertically = False
 .PrintTitleRows = ("$A$1:$k$1") ' jiuk - edit or omit as required
 .Orientation = xlPortrait ' jiuk - change as required
 .FitToPagesWide = iWidth
 .FitToPagesTall = iHeight
    
 End With
 
myTarget_Worksheet.PrintOut

theEND:
Set myTarget_Worksheet = Nothing

 End Sub