Currently, I have some code that copy pastes some graphs over to a newly created sheet and then turns that sheet into a pdf. However, if the graphs extend beyond one page, the graph is cutoff in the middle between the two pages. How do I ensure that this does not happen? Should I create a template specifically to copy/paste these graphs onto?
Here is the part that copy/pastes the graphs over.
x = 1
y = 1
For i = 1 To source.ChartObjects.Count
title_name = source.ChartObjects(i).Chart.ChartTitle.Text
If InStr(Replace(title_name, ",", ""), search) > 0 Then
source.ChartObjects(i).Activate
ActiveChart.ChartArea.Copy
wsTemp.Cells(x, y).PasteSpecial
x = x + 20
End If
Next
Next
wsTemp.ExportAsFixedFormat Type:=xlTypePDF, Filename:=NewFileName, Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True
wsTemp.Delete
Application.DisplayAlerts = True
LetsContinue:
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
Exit Sub
Whoa:
MsgBox Err.Description
Resume LetsContinue
End Sub
This depends on the procedure used to create the PDF. If it is taking the PrintArea of the worksheet and converting it then you could do this
1. When pasting the graph you should also set the print area to cover the width of the graph.
Something along the lines of this:
rngPrintArea = Range(wsTemp.cells(1,1), wsTemp.cells(x, y + 1))
wsTemp.PageSetup.PrintArea = rngPrintArea.Address
2. If this issue isn't with the PrintArea on the spreadsheet and is
occurring because the width of the graph is just bigger than the
fixed size allotted for 1 page when using the PDF procedure then you
need to decrease the size of the pasted graph.
ActiveChart.Width = 10 ' Change 10 to whatever width is acceptable for the PDF procedure
ActiveChart.Heigth = 10 ' Change 10 to whatever height is acceptable for the PDF procedure
Related
I'll try to keep this short. I'm working on a Excel project and I have to print at the end a single sheet, the problem is the printed PDF is too small, so I've looked up for it in different forums and I found out that I had to turn .FitToPagesTall = 0 In order that the excel worksheet don't get fit to one pdf page. The problem I'm struggling with now is that even if the pdf pages are bigger than before, It still small and It's making it hard to read. My idea is to print each 30 rows (for example) in a pdf page (Page1 --> Range("A1:E30"), Page2 --> Range("A31:E60").. etc, you got the idea)
Any ideas how I can do that please ?
Thanks in advance !
Update #1: Here's a screen shot of only a slice of my data range
Even if I set the .PrintArea to A:D, it still give the same result. To rephrase my request: I'm looking for a way to print different ranges in multiple pages.
thanks everyone for giving me a part out of ur time.
try to adapt the Orientation and fit the data horizontally, something like this :
With ActiveSheet.PageSetup
.PrintTitleRows = "$1:$1" 'to repeat your header on each page
.CenterHorizontally = True
.CenterVertically = True
.Orientation = xlLandscape ' or xlPortrait
.Zoom = False
.FitToPagesWide = 1 'fit to wide only
.FitToPagesTall = 0
End With
EDIT: auto-selection code added
My understanding of the question: how to print multiple selections from the same worksheet into PDF containing multiple pages (each selection = new page)
Multiple selection (ctlr) & Print Selection
Range("A1:E30, A31:E60") _
.PrintOut Copies:=1, Collate:=True 'your ranges in the quotes
'prompts user to choose destination where to save to
It is equal to manually selecting multiple ranges (holding ctrl) and selecting print selection when printing.
Edit - Code added
If you like the above idea, you might like the following code?
It constructs a string, such as: "A1:D30,A31:D60,A61:D90", which specifies ranges to be selected. Assumptions is that data is in columns A-D and last row can be found in column A. You can specify how many rows to print in my_step.
Sub select_and_print()
Dim s_rn, s_range As String
Dim i, my_step As Integer
Dim selections_count As Single
my_step = 30 'how many rows to include on 1 page
'to prevent extra page in some cases:
selections_count = WorksheetFunction.RoundUp((Cells(Rows.Count, 1).End(xlUp).Row / my_step), 0)
'String, which specifies selections in ws, between columns A - D
For i = my_step To selections_count * my_step Step my_step:
s_rn = "A" & (i - my_step + 1) & ":D" & i
If i = my_step Then
s_range = s_rn
Else
s_range = s_range + "," + s_rn
End If
Next i
'selection & print
Range(s_range).PrintOut Copies:=1, Collate:=True
End Sub
Building off #JC Guidicelli's answer, the important things I was missing was .FitToPagesTall = False. I don't know why Excel requires False and not 0, but that seems to be the way it is.
Sheets(Array("Sheet 1", "Sheet 2", "Sheet 3")).Select
With ActiveSheet.PageSetup
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = False
End With
and in my export command, I needed IgnorePrintAreas:=True.
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=<file path>, Quality:=xlQualityStandard, IgnorePrintAreas:=True
This gives me a PDF with all the data from Sheets 1, 2, and 3, and if data from those sheets is more than a page, it splits it over multiple pages without zooming it in.
My project is to create an easy to use list based off of a master list of items that are separated into separate sheets according to shop, and then format them ready for printing.
Currently, I have a macro button that divides up a master list into separate sheets depending on what value is in the shop column.
Next, I need to copy the formatting or set up the formatting of the new sheets in a very specific way: Print breaks to the right of column J, landscape, a specific header, and a box of text at the very bottom with space for a signature.
So far I've only managed to set the new sheets to landscape. Page break doesn't work.
Sub SetAttributes()
For Each xWorksheet In ActiveWorkbook.Worksheets
xWorksheet.PageSetup.Orientation = xlLandscape
xWorksheet.Cells.PageBreak = xlPageBreakNone
xWorksheet.Columns("K").PageBreak = xlPageBreakManual
Next xWorksheet
End Sub
Has anyone got any suggestions as to how I can move forward?
Ended up writing the specific formatting rather than code that simply copies the formatting.
Sub SetAttributes()
'Code telling excel that I want the following to apply to all my
'sheets in this workbook
For Each xWorksheet In ActiveWorkbook.Worksheets
'Set the page as landscape
xWorksheet.PageSetup.Orientation = xlLandscape
xWorksheet.Columns("K").PageBreak = xlPageBreakManual
'Set space for the header by increasing TOP margin
xWorksheet.PageSetup.TopMargin = _
Application.InchesToPoints(1.5)
'Inclusion Logo
xWorksheet.PageSetup.LeftHeader = "&G"
xWorksheet.PageSetup.LeftHeaderPicture.Filename = ThisWorkbook.Path +
"\Logo2.png"
'SSSFT logo
xWorksheet.PageSetup.RightHeader = "&G"
xWorksheet.PageSetup.RightHeaderPicture.Filename = ThisWorkbook.Path +
"\Logo1.png"
' Address
xWorksheet.PageSetup.CenterHeader = "&G"
xWorksheet.PageSetup.CenterHeaderPicture.Filename = ThisWorkbook.Path +
"\Address.png"
'Footer
xWorksheet.PageSetup.CenterFooter = "&A"
'set column width to help printing format
xWorksheet.Columns("A").ColumnWidth = 10
xWorksheet.Columns("C").ColumnWidth = 21
xWorksheet.Columns("E").ColumnWidth = 26
xWorksheet.Columns("F").ColumnWidth = 9
'Insert space for signatures 3 rows below the last row of
'data with a space for the pharmacy to date and sign
'Dim lastRow As Long
lastRow = xWorksheet.Cells(Rows.Count, 1).End(xlUp).Row
' wrap text
xWorksheet.Range("A:J").WrapText = True
'And move to the next sheet
Next xWorksheet
End Sub
I have built an Invoice worksheet that has a top portion (A1:K19) that will remain static; this is the top portion of the invoice. Below Row 19 starts the individual item lines that will be populated with what items are ordered.
I have created a macro for the user that will automatically format the invoice into a 1 page PDF and autohide the unused line item rows; however I have pictures in each line item line.
When I run my macro it hides all the pictures expect the last one. How can I hide the last image box that just sticks out and doesn't hide with row. If I individually hide that row alone it hides, but with a group it does not.
Below is the current VBA script I have written.
Sub Save_Quote_As_PDF()
Application.ScreenUpdating = False
For i = 20 To 59
If ActiveSheet.Cells(i, 3) = "" Then
ActiveSheet.Cells(i, 3).EntireRow.Hidden = True
End If
Next i
Dim PdfFilename As Variant
PdfFilename = Application.GetSaveAsFilename( _
InitialFileName:=ActiveWorkbook.Path & "\" & ActiveSheet.Range("N2").Value, _
FileFilter:="PDF, *.pdf", _
Title:="Save As PDF")
If PdfFilename <> False Then
With ActiveSheet.PageSetup
.Orientation = xlPortrait
.PrintArea = "$A$1:$K$78"
.PrintTitleRows = ActiveSheet.Rows(19).Address
.Zoom = False
.FitToPagesTall = 1
.FitToPagesWide = 1
End With
ActiveSheet.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=PdfFilename, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=False, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=True
End If
For i = 20 To 59
If ActiveSheet.Cells(i, 3) = "" Then
ActiveSheet.Cells(i, 3).EntireRow.Hidden = False
End If
Next i
Application.ScreenUpdating = True
End Sub
Here is a screenshot of the pdf section that shows the pic object showing
Screenshot of Image Not Hiding in PDF results
I recreated your code above with my own sample data. The issue seems to be when the images don't have "move and size with cells" (in their properties).
If you have code elsewhere, that's inserting those images then you'll need to do this,
Sub Move_Size()
Dim i As Long
For i = 1 To ActiveSheet.Shapes.Count
On Error Resume Next
With ActiveSheet.Shapes.Item(i)
.Placement = xlMoveAndSize
.PrintObject = True
End With
Next i
On Error Goto 0
End Sub
Taken from here
I have some code written to build a list of worksheets in a string based on if the user selects a checkbox to include the sheet in the PDF report. See below:
If CheckBox1.Value = True Then
PDFsheets = "Sheet11"
End If
If CheckBox2.Value = True Then
If PDFsheets = "" Then
PDFsheets = "Sheet13"
Else
PDFsheets = PDFsheets & ",Sheet13"
End If
End If
If CheckBox3.Value = True Then
If PDFsheets = "" Then
PDFsheets = "Sheet2"
Else
PDFsheets = PDFsheets & ",Sheet2"
End If
End If
For example, when all 3 checkboxes are selected, MsgBox PDFsheets shows the result Sheet11, Sheet13, Sheet2
NOW, when I try to do a multiple sheet select I get Run-Time Error 9 - Subscript Out of Range. The different things I've tried include:
ThisWorkBook.Sheets(PDFsheets).Select
ThisWorkBook.Sheets(Array(PDFsheets)).Select
xPDF() = Split(PDFsheets, ",")
ThisWorkBook.Sheets(xPDF).Select
xPDF() = Split(PDFsheets, ",")
ThisWorkBook.Sheets(Array(xPDF)).Select
xPDF() = Split(PDFsheets, ",")
For i = 0 to Application.CountA(xPDF) - 1
Sheets(xPDF(i)).Select
next i
ALSO, for the sake of brevity I have tried all of the above examples with ActiveWorkbook instead of ThisWorkBook. PLUS, I've tried rewriting my string building part to reference the sheets names instead of numbers with all of the examples above. So instead of Sheet11, Sheet13, Sheet2 the result was "Sheet11", "Sheet13, "Sheet2" with the double quotes around the sheets.
I've look at other questions and code examples on here and elsewhere that show this same goal and I'm using the selection line exactly as they have had it and I'm getting the Subscript out of range error. (I've also verified everything is spelled correctly)
Additional Note if I try typing the string value directly in it works - ThisWorkBook.Sheets("Sheet11, Sheet13, Sheet2").Select - However, this doesn't allow me to keep it variable.
Your are building a comma separated string that you must convert into an array. You were very close:
Sub BuildAString()
Dim PDFsheets As String
Dim s As Worksheet
PDFsheets = "Sheet1,Sheet2,Sheet3"
ary = Split(PDFsheets, ",")
Sheets(ary).Select
Selection.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
"C:\TestFolder\Book1.pdf", Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _
True
End Sub
Note this makes 1 pdf file for all three sheets. You would use a loop if you wanted 3 separate files.Note that there are no spaces inPDFsheets because my worksheet names have no spaces.
This script is to reset a template, by copying a hidden worksheet template and deleting the existing sheet (after repopulating some reference data). I have tested it and it runs fine in debugging mode.
Option Explicit
Sub reset_PrintLayout_byCopy()
'the script replace the used printlayout with a copy from the hidden master.
Dim MeetingData() As String
Dim i As Integer
Dim j As Integer
Dim currentSheet As String
Dim datacolumns() As String
Dim userConfirm As String
ReDim Preserve MeetingData(3, 2)
ReDim Preserve datacolumns(2)
'warning about deleting data
userConfirm = MsgBox(Prompt:="Resetting the template will erase all data on the " _
& "PrintLayout Template. Choose ""Cancel"", if you wish to save the file first", _
Buttons:=vbOKCancel, Title:="Data to be erased!")
If (userConfirm = vbCancel) Then
Exit Sub
End If
'set parameters
datacolumns(0) = "D1"
datacolumns(1) = "I1"
'stop screen updating and displaying warnings
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'set active sheet
currentSheet = ActiveSheet.Name
'capture meeting data already filled out
For j = 0 To UBound(datacolumns) - 1
For i = 1 To 3
If Worksheets(currentSheet).Cells(i, Range(datacolumns(j)).Column).Value <> "" Then
MeetingData(i - 1, j) = Worksheets(currentSheet).Cells(i, Range(datacolumns(j)).Column).Value
End If
Next i
Next j
'make hidden template visible
Worksheets("hiddenPrintLayoutTemplate").Visible = True
'Rename current Sheet
Sheets(currentSheet).Name = "used_Print_Layout"
''add a new sheet
' ActiveWorkbook.Worksheets.Add(before:=Sheets("used_Print_Layout")).Name = "PrintLayout Template"
'copy hiddentemplate before current sheet
Worksheets("hiddenPrintLayoutTemplate").Copy before:=Sheets("used_Print_Layout")
ActiveSheet.Name = currentSheet
'set rowheight for title rows
Range("A12").EntireRow.RowHeight = 24
Range("A18").EntireRow.RowHeight = 24
'delete current used printlayout
Worksheets("used_Print_Layout").Delete
'refilled meeting data
For j = 0 To UBound(datacolumns) - 1
For i = 1 To 3
If MeetingData(i - 1, j) <> "" Then
Worksheets(currentSheet).Cells(i, Range(datacolumns(j)).Column).Value = MeetingData(i - 1, j)
End If
Next i
Next j
'hide PrintLayout template
'Worksheets("hiddenPrintLayoutTemplate").Visible = xlSheetVeryHidden
'Sheets("PrintLayout Template").Select
'activate screenupdating and display warnings
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
When run it in macro mode on button, it runs, but excel crashes, when it is done. I cannot find what the issue is. Any ideas?
I am not sure if by debugging you mean stepping through line by line, but you could try inserting stop statements at key points in the code. So for example, you could put a stop statement in the following part:
'capture meeting data already filled out
For j = 0 To UBound(datacolumns) - 1
For i = 1 To 3
If Worksheets(currentSheet).Cells(i, Range(datacolumns(j)).Column).Value <> "" Then
MeetingData(i - 1, j) = Worksheets(currentSheet).Cells(i,Range(datacolumns(j)).Column).Value
End If
Next i
Next j
stop
'make hidden template visible
Worksheets("hiddenPrintLayoutTemplate").Visible = True
You could see if the code runs fine up until that point (i.e. run it without debugging). If it does, remove the stop statement and place it further down the code. Repeat this until you find the statements which cause your crash - perhaps the reason would appear then.
In general, if you get an odd crash in Excel VBA, try switching the Windows default printer to Microsoft XPS Document Writer. Seems odd, but that has worked for me on problems where I've wasted many hours only to find this is the culprit.