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

What do {} around a formula in the formula bar mean?
{Formula} means the formula was entered using Ctrl+Shift+Enter signifying an old-style array formula.

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
 

Subscribe on YouTube

Watch MrExcel Video

Forum statistics

Threads
1,106,544
Messages
5,511,950
Members
408,870
Latest member
SBrowning

This Week's Hot Topics

  • Turn fraction around
    Hello I need to turn a fraction around, for example I have 1/3 but I need to present as 3/1
  • TIme Clock record reformatting to ???
    Hello All, I'd like some help formatting this (Tbl-A)(Loaded via Power Query) [ATTACH type="full" width="511px" alt="PQdata.png"]22252[/ATTACH]...
  • TextBox Match
    hi, I am having a few issues with my code below, what I need it to do is when they enter a value in textbox8 (QTY) either 1,2 or 3 the 3 textboxes...
  • Using Large function based on Multiple Criteria
    Hello, I can't seem to get a Large formula to work based on two criteria's. I can easily get a oldest value based one value, but I'm struggling...
  • Can you check my code please
    Hi, Im going round in circles with a Compil Error End With Without With Here is the code [CODE=rich] Private Sub...
  • Combining 2 pivot tables into 1 chart
    Hello everyone, My question sounds simple but I do not know the answer. I have 2 pivot tables and 2 charts that go with this. However I want to...
Top