我有一個宏可以列印每個報告過濾器（名稱）的所有資料透視表。如果我列印為 pdf，它會單獨列印每個資料透視表。我想要做的是將每個資料透視表（每個過濾器選項）合并到一個 pdf 檔案中。下面是我目前使用的代碼。我希望有人知道如何調整列印輸出部分以將所有支點組合成一個 pdf
Sub PrintAll()
'
' PrintAll Macro
' Print activity table for all employees
'
Response = MsgBox("Do you want to print the overview of all employees?", vbYesNo)
If Response = vbNo Then Exit Sub
' always refresh the table
ActiveSheet.PivotTables("PivotTable1").PivotCache.Refresh
On Error Resume Next
Dim pf As PivotField
Dim pi As PivotItem
Set pf = ActiveSheet.PivotTables("PivotTable1").PivotFields("name")
For Each pi In pf.PivotItems
ActiveSheet.PivotTables("PivotTable1").PivotFields("name").CurrentPage = pi.Name
' now check whether the current page is indeed the desired one,
' if not, the page of that e,mployee is empty so don't print
If ActiveSheet.PivotTables("PivotTable1").PivotFields("name").CurrentPage.Caption = pi.Caption Then
End If
Next
ActiveSheet.PrintOut 'use this for printing
' ActiveSheet.PrintPreview 'use this for testing
'
End Sub
uj5u.com熱心網友回復：
This is a problem I ran into a few years back, and there is no out-of-the-box solution. But it is fairly straightforward.
Basically, with each filter applied to the pivot table, you create a separate and temporary worksheet with a copy of the filtered table. Then Select all those temporary sheets and export them to a PDF.
The example below shows a Sub created to perform these actions. By creating a separate Sub, you can call it for different pivot tables and/or different filters as needed.
Option Explicit
Sub test()
PTtoPDF Sheet3.PivotTables(1), "name"
End Sub
Sub PTtoPDF(ByRef pt As PivotTable, ByVal fieldName As String)
'--- access the worksheet for the given pivot table
Dim ws As Worksheet
Set ws = pt.Parent
'--- make sure the pivot table is up to date
pt.PivotCache.Refresh
'--- filter the pivot by the given field
Dim pf As PivotField
Set pf = pt.PivotFields(fieldName)
'--- the pivot table is filtered for each name and a copy
' of that filtered table creates a (separate) new
' (temporary) worksheet. we'll create an array to hold
' the worksheet names so we can create the PDF
Dim wsNames() As Variant
Dim wsCount As Long
wsCount = 0
'--- stop the screen from updating to go faster
Application.ScreenUpdating = False
Dim pi As PivotItem
For Each pi In pf.PivotItems
pf.CurrentPage = pi.Name
'--- copy the filtered PT to a new sheet and save the name
With ThisWorkbook
wsCount = wsCount 1
ReDim Preserve wsNames(1 To wsCount)
ws.Copy After:=.Sheets(ws.Name)
Dim newWS As Worksheet
Set newWS = .Sheets(.Sheets(ws.Name).Index 1)
wsNames(wsCount) = newWS.Name
End With
Next pi
ThisWorkbook.Sheets(wsNames).Select
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:="sample.pdf", _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=True
'--- finally delete the temporary sheets
' (disable the Alerts so that Excel doesn't ask
' to delete each worksheet)
Dim previousAlertState As Boolean
previousAlertState = Application.DisplayAlerts
Application.DisplayAlerts = False
Dim sheetName As Variant
For Each sheetName In wsNames
ThisWorkbook.Sheets(sheetName).Delete
Next sheetName
'--- turn it back on
Application.DisplayAlerts = previousAlertState
Application.ScreenUpdating = True
End Sub
uj5u.com熱心網友回復：
為每個資料透視表創建一個包含一張作業表的臨時作業簿，并從中創建 PDF。
Option Explicit
Sub PrintAll()
'
' PrintAll Macro
' Print activity table for all employees
'
Dim response
response = MsgBox("Do you want to print the overview of all employees?", vbYesNo)
If response = vbNo Then Exit Sub
Dim pt As PivotTable, pf As PivotField, pi As PivotItem
Dim wbPDF As Workbook, n As Integer, pdfName As String
' create temporary workbook
Set wbPDF = Workbooks.Add(1)
Set pt = ActiveSheet.PivotTables("PivotTable1")
With pt
.PivotCache.Refresh ' always refresh the table
Set pf = .PivotFields("name")
For Each pi In pf.PivotItems
.PivotFields("name").CurrentPage = pi.Name
' now check whether the current page is indeed the desired one,
' if not, the page of that e,mployee is empty so don't print
If .PivotFields("name").CurrentPage.Caption = pi.Caption Then
n = n 1
If n > 1 Then
wbPDF.Sheets.Add after:=wbPDF.Sheets(n - 1)
End If
.TableRange2.Copy wbPDF.Sheets(n).Range("A1")
Else
MsgBox "Error selecting " & pi.Name, vbExclamation
End If
Next
End With
' create pdf
pdfName = "AllEmployees_" & Format(Now, "yyyymmdd_hhmmss") & ".pdf"
wbPDF.ExportAsFixedFormat Type:=xlTypePDF, Filename:=pdfName
wbPDF.Close False
MsgBox "PDF created " & pdfName, vbInformation
End Sub
轉載請註明出處，本文鏈接：https://www.uj5u.com/houduan/338657.html
上一篇：Excel按多個條件過濾表格值