VBA | Export To Multi-Page PDF - excel

So I have a worksheet with a landscape orientation that I am exporting to a PDF. I can achieve this without any issues by selecting the usedRange of the activesheet, but the content prints to just one page, even if the used range is outside of the print area. How might I go about getting it to print a multi-page PDF in this case? My code is below:
Dim numSheets As Integer
numSheets = UBound(SlotArray)
For z = LBound(SlotArray) To UBound(SlotArray)
Set attendSh = ThisWorkbook.Sheets(SlotArray(z))
attendSh.Activate
ThisWorkbook.ActiveSheet.UsedRange.Select
Next z
Select Case numSheets
Case "0"
ThisWorkbook.Sheets(Array(SlotArray(0))).Select
Case "1"
ThisWorkbook.Sheets(Array(SlotArray(0), SlotArray(1))).Select
Case "2"
ThisWorkbook.Sheets(Array(SlotArray(0), SlotArray(1), SlotArray(2))).Select
Case "3"
ThisWorkbook.Sheets(Array(SlotArray(0), SlotArray(1), SlotArray(2), SlotArray(3))).Select
Case "4"
ThisWorkbook.Sheets(Array(SlotArray(0), SlotArray(1), SlotArray(2), SlotArray(3), SlotArray(4))).Select
Case "5"
ThisWorkbook.Sheets(Array(SlotArray(0), SlotArray(1), SlotArray(2), SlotArray(3), SlotArray(4), SlotArray(5))).Select
Case "6"
ThisWorkbook.Sheets(Array(SlotArray(0), SlotArray(1), SlotArray(2), SlotArray(3), SlotArray(4), SlotArray(5), SlotArray(6))).Select
End Select
Application.PrintCommunication = False
With ThisWorkbook.ActiveSheet.PageSetup
.Orientation = xlLandscape
.CenterHorizontally = True
'.Zoom = 90
.FitToPagesWide = 1
.FitToPagesTall = 1
.PrintComments = False
.PrintGridlines = False
End With
Application.PrintCommunication = True
Selection.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
FilePath & "\" & Year & " Monthly Attendance\" & "\" & Year & " " & Month & " Attendance.pdf", Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _
False
where slotArray is an array of sheet names.

Try applying the PageSetUp to every sheet in the array.
Dim numSheets As Long, Z As Long
numSheets = UBound(SlotArray)
Dim ws As Worksheet
For Z = LBound(SlotArray) To UBound(SlotArray)
Set ws = ThisWorkbook.Sheets(SlotArray(Z))
With ws.PageSetup
.Orientation = xlLandscape
.CenterHorizontally = True
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = False
.PrintComments = xlPrintNoComments
.PrintGridlines = False
.PrintArea = ws.UsedRange.Address
End With
Next Z
ThisWorkbook.Sheets(SlotArray).Select
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:="Attendance.pdf", Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
MsgBox "Printed " & vbLf & Join(SlotArray, vbLf)

Related

excel PDF printing macro not working correctly

This macro is not working correctly. The desired output is that automatically change the values of one cell (a list) that is formulated to change other info in the same page.
Currently is printing the whole list correctly but is not changing the info in the other cells, even tho this formulas are correct and working accordingly.
"
Sub Imprimir()
' SET UP APP -------------------
Application.ScreenUpdating = False
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False
Application.Calculation = xlManual
Application.DisplayAlerts = False
ThisWorkbook.Activate
' INICIO -------------------
N = Sheets("Ficha Resumen_ajustada").Range("Q1").Value
For i = 1 To N
Sheets("Ficha Resumen_ajustada").Range("I7").Value = Sheets("Base").Cells(8 + i, 1).Value
With Worksheets("Ficha Resumen_ajustada")
'obj_visiibility = .Visible
'.Visible = xlSheetVisible
.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=ThisWorkbook.Path & "_" & CStr(Sheets("Base").Cells(8 + i, 1).Value), _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
'.Visible = obj_visibility
End With
Next
' FIN -------------------
' SET UP APP -------------------
Application.DisplayAlerts = True
Application.Calculation = xlAutomatic
Application.ScreenUpdating = True
Application.EnableEvents = True
ActiveSheet.DisplayPageBreaks = True
End Sub
"
any idea why is this happening ?

Attempting to print table headers to each page of a pdf on Excel export

I am running a workbook where I am formatting data and then printing to a PDF for delivery to clients. What I would like to do is take my table headers, which are in range A4:F4 on the fist page, I want that to appear as A1:F1 on subsequent pages.
Here is the code I am trying:
'************* Formats Data as Table ******************************
MyTableRange = Range("a4:" & myrange).Address
Range("A4:F4").Select
Range(Selection, Selection.End(xlDown)).Select
ActiveSheet.ListObjects.Add(xlSrcRange, Range(MyTableRange), , xlYes).Name = "NewTable"
ActiveSheet.ListObjects("NewTable").TableStyle = "TableStyleMedium1"
'************* Set Table Headers to Repeat ******************************
Application.PrintCommunication = False
With ActiveSheet.PageSetup
.PrintTitleRows = "A4:F4"
End With
Application.PrintCommunication = True
'*********** Formatting the File Name for the Export *************
dt = Format(Now, "mm.dd.yyyy hh mm")
fName = EXPORTS & "AccountEnding" & AccountNumber & " - Created On - "
If Len(Dir(fName & ".pdf")) > 0 Then sep = " - "
fName = fName & sep & dt & ".pdf"
'***********Setting Export to PDF Parameters***********
Application.PrintCommunication = False
With Sheets("LTXN Report").PageSetup
.FitToPagesWide = 1
.FitToPagesTall = False
End With
Application.PrintCommunication = True
ws.ExportAsFixedFormat Type:=xlTypePDF, Filename:=fName, _
Quality:=xlQualityStandard, IncludeDocProperties:=True, _
IgnorePrintAreas:=False, OpenAfterPublish:=True
Can someone tell me what I am doing wrong here?

Convert excel columns towards different pdf pages

Below you can find my code that is working for a certain area. But I want to add a new element in the code but I can't find it how I can do it. The first area is A1:E42, but now I have one worksheet where I have 3 area. A1:E42, H1:K42 and O1:R42). How do I need to rewrite my code that the first area comes on the first pdf page, the second area on the second page et cetera.
Sub SavePDF()
Dim ws As Worksheet
Set ws = ThisWorkbook.ActiveSheet
With ws.PageSetup
.Orientation = xlLandscape
.Zoom = False
.FitToPagesTall = 1
.FitToPagesWide = 1
.PrintArea = "A1:E42"
End With
Set ws = Nothing
Sheets("Offerte_M").ExportAsFixedFormat x1TypePDF, Filename:= _
"C:\Intel\" & ActiveSheet.Range("F21").Value & ".pdf" _
, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
:=False, OpenAfterPublish:=False
MsgBox "Offerte has been saved as PDF. Press send now."
I thought maybe this was the correct way, but that doesn't work also.
Sub CommandButton1_Click()
Application.ScreenUpdating = False
Offerte_M.PageSetup.PrintArea = "A1:E42"
Offerte_M.PageSetup.PrintArea = "H1:K42"
Offerte_M.PageSetup.PrintArea = "O1:R42"
Worksheets(Array("Offerte_M")).Select.ActiveSheet.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:="C:\Intel\" & ActiveSheet.Range("F21").Value & ".pdf", _
OpenAfterPublish:=True
Offerte_M.PageSetup.PrintArea = ""
Offerte_M.PageSetup.PrintArea = ""
Offerte_M.PageSetup.PrintArea = ""
Offerte_M.Select
Application.ScreenUpdating = True
End Sub

Print to PDF (A3 landscape) export size ends up at 160cm x 110cm

I have large spreadsheet that I'm looping through and printing each page to a pdf report.
I'm trying to print them A3 Landscape, however the actual export size is far larger than an A3 page.
Any suggestions I what I'm doing wrong?
Here is my current code:
Sub printChartsA3()
Application.ScreenUpdating = False
Dim sPrintArea As String
Dim wks As Worksheet
Const path As String = "E:\A3 Charts\"
sPrintArea = "A1:BM69"
For Each wks In Worksheets
Application.PrintCommunication = False
wks.PageSetup.PaperSize = xlPaperA3
wks.PageSetup.Orientation = xlLandscape
wks.PageSetup.LeftMargin = Application.InchesToPoints(0.25)
wks.PageSetup.RightMargin = Application.InchesToPoints(0.25)
wks.PageSetup.PrintArea = sPrintArea
wks.PageSetup.Zoom = False
wks.PageSetup.FitToPagesWide = 1
'wks.PageSetup.FitToPagesTall = 1 'not sure if this one is needed?
Application.PrintCommunication = True
wks.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=path & wks.Name & ".pdf", _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
Next
Set wks = Nothing
Application.ScreenUpdating = True
End Sub

VBA Excel ERROR creating a second pivot table from the same database

I'm not a rookie but not yet a pro on VBA Excel and I have encounter myself with a problem I have being struggling for a while.
Tried on google and this forum to read some data for a guide or the answer without success so I'll explain it to you hoping someone can give me a hint or enlightenment.
I want to code a VBA Macro that creates a Sheet from my Database called "ClientProperties" in which I'll create a Pivot Table "PT2" containing all the client names on a filtered state/Country and some properties like promotions name applied for that client, and the promotion value sorted by month. Then It will create a new sheet with the name of every state/Country on my Database but in each sheet I have to create one Pivot Table for each client ("PT1", "PT2", ... "PTn") showing the product categories that client has and sales sorted by month; Below that Pivot table I have to paste the properties from the "PT2" for that client.
I can create the "PT2", apply the filters and sort the information as needed without any problems but when I try to create the "PT1" it shows the error:
"Error '5' has occurred at runtime:
Invalid argument or procedure call".
The fist Pivot is actually created like this:
Sheets.Add After:=ActiveSheet
ActiveSheet.Name = "ClientProperties"
ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:="Base!R1C1:R50C100"_
Version:=6).CreatePivotTable TableDestination:="ClientProperties!R3C1", TableName:="DT1", DefaultVersion:=6
The second (The one with error) like this (Note: PL(X) is an array of strings [state/Country name]):
For X = 0 To UBound(PL, 1)
Sheets.Add After:=ActiveSheet
ActiveSheet.Name = "" & PL(x) & ""
ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:="Base!R1C1:R50C100"_
Version:=6).CreatePivotTable TableDestination:="" & PL(X) & "R8C23", TableName:="DT2", DefaultVersion:=6
Here is my code resumed:
Global LBD As Long, ABD As Integer, LBB As Long, ABB As Integer, PL(11) As String, CA() As String, AN As String, CTE As Boolean, TR As String * 1, FBB As Integer
Global ASS() As String, CAP() As String, FTD As Integer, ITD As Boolean, LTD As Integer, PN As String * 1, CRK As Integer, CANCEL As Boolean
Sub Main()
Call Variables
Worksheets("Base").Visible = True
Worksheets("Base").Select
LBD = Rows(1, 1)
ABD = Columns(1, 1)
Call AditionalProcess
Call ClientProps
Call SummaryTabs
Worksheets("Base").Visible = False
Worksheets("ClientProperties").Visible = False
End Sub
The Other modules are:
Sub Variables()
If TR = "M" Then
CTE = True
ReDim CA(3) As String
CA(0) = "Club"
CA(1) = "Conv"
CA(2) = "Reg"
CA(3) = "Ret"
Else
CTE = False
ReDim CA(3) As String
CA(0) = "Whs"
CA(1) = "C3"
CA(2) = "C5"
CA(3) = "Dist"
End If
PL(0) = "CALIFORNIA"
PL(1) = "FLORIDA"
If TR = "M" Then PL(2) = "AUSTIN" Else PL(2) = "HOUSTON"
PL(3) = "HAWAI"
PL(4) = "NEW JERSEY"
PL(5) = "ARIZONA"
PL(6) = "PENSILVANIA"
PL(7) = "VIRGINIA"
PL(8) = "MICHIGAN"
PL(9) = "GEORGIA"
PL(10) = "COLORADO"
PL(11) = "OHIO"
End Sub
Function Rows(X As Long, Y As Integer) As Long
Do While Cells(X, Y) <> Empty
X = X + 1
Loop
Rows = X - 1
End Function
Function Columns(X As Long, Y As Integer) As Long
Do While Cells(X, Y) <> Empty
Y = Y + 1
Loop
Columns = Y - 1
End Function
Sub AditionalProcess()
Worksheets("Base").Select
Range(Cells(2, 8), Cells(LBD, 8)).Copy
Sheets.Add After:=ActiveSheet
ActiveSheet.Paste
Application.CutCopyMode = False
Columns("A:A").RemoveDuplicates Columns:=1, Header:=xlNo
ReDim CAP(20) As String
For Y = 1 To 20
CAP(Y - 1) = Range(Cells(Y, 1), Cells(Y, 1))
Next Y
Application.DisplayAlerts = False
ActiveSheet.Delete
Application.DisplayAlerts = True
End Sub
Sub ClientProps()
Sheets.Add After:=ActiveSheet
ActiveSheet.Name = "ClientProperties"
ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:="Base!R1C1:R" & LBD & "C" & ABD & "", Version:=6).CreatePivotTable TableDestination:="ClientProperties!R3C1", TableName:="PT2", DefaultVersion:=6
Sheets("BB´s").Select
Cells(3, 1).Select
With ActiveSheet.PivotTables("PT2")
.ColumnGrand = True
.HasAutoFormat = True
.DisplayErrorString = False
.DisplayNullString = True
.EnableDrilldown = True
.ErrorString = ""
.MergeLabels = False
.NullString = ""
.PageFieldOrder = 2
.PageFieldWrapCount = 0
.PreserveFormatting = True
.RowGrand = True
.SaveData = True
.PrintTitles = False
.RepeatItemsOnEachPrintedPage = True
.TotalsAnnotation = False
.CompactRowIndent = 1
.InGridDropZones = False
.DisplayFieldCaptions = True
.DisplayMemberPropertyTooltips = False
.DisplayContextTooltips = True
.ShowDrillIndicators = True
.PrintDrillIndicators = False
.AllowMultipleFilters = False
.SortUsingCustomLists = True
.FieldListSortAscending = False
.ShowValuesRow = False
.CalculatedMembersInFilters = False
.RowAxisLayout xlCompactRow
.PageFieldOrder = xlDownThenOver
End With
With ActiveSheet.PivotTables("PT2").PivotCache
.RefreshOnFileOpen = False
.MissingItemsLimit = xlMissingItemsDefault
End With
ActiveSheet.PivotTables("PT2").RepeatAllLabels xlRepeatLabels
With ActiveSheet.PivotTables("PT2").PivotFields("FY")
.Orientation = xlPageField
.Position = 1
End With
With ActiveSheet.PivotTables("PT2").PivotFields("Client")
.Orientation = xlPageField
.Position = 1
End With
With ActiveSheet.PivotTables("PT2")
.ColumnGrand = False
.RowGrand = False
End With
ActiveSheet.PivotTables("PT2").AddDataField ActiveSheet.PivotTables("PT2").PivotFields("M01"), " M01", xlSum
ActiveSheet.PivotTables("PT2").AddDataField ActiveSheet.PivotTables("PT2").PivotFields("M02"), " M02", xlSum
ActiveSheet.PivotTables("PT2").AddDataField ActiveSheet.PivotTables("PT2").PivotFields("M03"), " M03", xlSum
ActiveSheet.PivotTables("PT2").AddDataField ActiveSheet.PivotTables("PT2").PivotFields("M04"), " M04", xlSum
ActiveSheet.PivotTables("PT2").AddDataField ActiveSheet.PivotTables("PT2").PivotFields("M05"), " M05", xlSum
ActiveSheet.PivotTables("PT2").AddDataField ActiveSheet.PivotTables("PT2").PivotFields("M06"), " M06", xlSum
ActiveSheet.PivotTables("PT2").AddDataField ActiveSheet.PivotTables("PT2").PivotFields("M07"), " M07", xlSum
ActiveSheet.PivotTables("PT2").AddDataField ActiveSheet.PivotTables("PT2").PivotFields("M08"), " M08", xlSum
ActiveSheet.PivotTables("PT2").AddDataField ActiveSheet.PivotTables("PT2").PivotFields("M09"), " M09", xlSum
ActiveSheet.PivotTables("PT2").AddDataField ActiveSheet.PivotTables("PT2").PivotFields("M10"), " M10", xlSum
ActiveSheet.PivotTables("PT2").AddDataField ActiveSheet.PivotTables("PT2").PivotFields("M11"), " M11", xlSum
ActiveSheet.PivotTables("PT2").AddDataField ActiveSheet.PivotTables("PT2").PivotFields("M12"), " M12", xlSum
With ActiveSheet.PivotTables("PT2").PivotFields("PROMOS")
.Orientation = xlRowField
.Position = 1
End With
LBB = Rows(8, 1)
ABB = Columns(7, 1)
Range(Cells(8, 2), Cells(LBB, ABB)).Style = "Comma"
Range(Cells(8, 2), Cells(LBB, ABB)).NumberFormat = "_-* #,##0_-;-* #,##0_-;_-* ""-""??_-;_-#_-"
ActiveSheet.PivotTables("PT2").PivotFields("PROMOS").Subtotals = Array(False, False, False, False, False, False, False, False, False, False, False, False)
ActiveWorkbook.ShowPivotTableFieldList = False
End Sub
Sub SummaryTabs()
For X = 0 To UBound(PL, 1)
Sheets.Add After:=ActiveSheet
ActiveSheet.Name = "" & PL(X) & ""
ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:="Base!R1C1:R" & LBD & "C" & ABD & "", Version:=6).CreatePivotTable TableDestination:="" & PL(X) & "!R8C23", TableName:="PT1." & (X+2), DefaultVersion:=6
End Sub
At this point is where the error message appears and that's why i cut the code...
Two things:
you are missing '!' before the range in loop (!R8C23 instead of R8C23)
PivotTable name is the same in the loop, that will not work
Also you can use the same PivotCache for all the pivots, as it's always the same, like here (this code has both issues fixed):
Dim ws As Worksheet
Set ws = Sheets.Add(After:=ActiveSheet)
ws.Name = "ClientProperties"
Dim pc as PivotCache
Set pc = ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:="Base!R1C1:R50C100", _
Version:=6)
pc.CreatePivotTable TableDestination:="ClientProperties!R3C1", TableName:="DT1", DefaultVersion:=6
For X = 0 To UBound(PL, 1)
Set ws = Sheets.Add(After:=ActiveSheet)
ws.Name = "" & PL(x) & ""
pc.CreatePivotTable TableDestination:="" & PL(X) & "!R8C23", TableName:="DT" & (X+2), DefaultVersion:=6
I Just found the answer:
The sheet name in:
TableDestination:="" & PL(X) & "!R8C23"
needs to be surrounded with single quotes in order for it to work:
TableDestination:="'" & PL(X) & "'!R8C23"
Thank you all for your support!!!

Resources