Add in Fit to 1 Page on Print out

Ibbo1978

New Member
Joined
Mar 6, 2017
Messages
20
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
 

Some videos you may like

Excel Facts

Quick Sum
Select a range of cells. The total appears in bottom right of Excel screen. Right-click total to add Max, Min, Count, Average.

Jack in the UK

Well-known Member
Joined
Feb 16, 2002
Messages
3,215
Hi Ibb01978

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

Code:
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

New Member
Joined
Mar 6, 2017
Messages
20
I think I actually just need the selection to reduce to fit 1 page in the PDF? is that possible?
 

Jack in the UK

Well-known Member
Joined
Feb 16, 2002
Messages
3,215
Untested maybe closer to what you require
Regards

jiuk

Code:
 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

Well-known Member
Joined
Feb 16, 2002
Messages
3,215
- or -

jiuk
Code:
 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
 

Watch MrExcel Video

Forum statistics

Threads
1,102,435
Messages
5,486,866
Members
407,567
Latest member
spinitback

This Week's Hot Topics

Top