如何使用vba将多个图表从excel导出为单个pdf？
我对VBA来说是全新的，需要使用vba将多个图表从excel工作簿导出为单个pdf。 我知道这是可能的导出graphics作为单独的pdf或jpgs，但它可能会把工作簿中的所有graphics变成一个PDF使用VBA？ 任何build议将不胜感激，因为我似乎无法find我在别处寻找什么。
我的代码到目前为止打印每个图表的PDF，但每个图表被覆盖下一个打印。 我的代码如下：
Sub exportGraphs() Dim Ws As Worksheet Dim Filename As String Filename = Application.InputBox("Enter the pdf file name", Type:=2) Sheets("Status and SLA trends").Select ActiveSheet.ChartObjects("Chart 4").Activate ActiveChart.ExportAsFixedFormat xlTypePDF, Filename, xlQualityStandard ActiveSheet.ChartObjects("Chart 1").Activate ActiveChart.ExportAsFixedFormat xlTypePDF, Filename, xlQualityStandard Sheets("Current Issue Status").Select ActiveSheet.ChartObjects("Chart 2").Activate ActiveChart.ExportAsFixedFormat xlTypePDF, Filename, xlQualityStandard ActiveSheet.ChartObjects("Chart 5").Activate ActiveChart.ExportAsFixedFormat xlTypePDF, Filename, xlQualityStandard ActiveSheet.ChartObjects("Chart 8").Activate ActiveChart.ExportAsFixedFormat xlTypePDF, Filename, xlQualityStandard End Sub 最后，我只是将一个表格数组导出到pdf中，因为多个图表在不同的工作表上，我不需要改变它们的格式。 我使用下面的代码片段做了它
Sheets(Array("Current Issue Status", "Status and SLA trends")).Select Dim saveLocation As String saveLocation = Application.GetSaveAsFilename( _ fileFilter:="PDF Files (*.pdf), *.pdf") If saveLocation <> "False" Then ActiveSheet.ExportAsFixedFormat xlTypePDF, saveLocation, xlQualityStandard End If
这是你正在尝试？
逻辑 ：将所有图表复制到临时工作表中，然后使用Excel的内置工具创buildPDF。 pdf一旦完成，删除临时表。 这将使用vba将Sheets("Status and SLA trends")多个图表Sheets("Status and SLA trends")导出为单个PDF。
代码（试验和testing） ：
Option Explicit Sub Sample() Dim ws As Worksheet, wsTemp As Worksheet Dim chrt As Shape Dim tp As Long Dim NewFileName As String On Error GoTo Whoa Application.ScreenUpdating = False NewFileName = "C:\Charts.Pdf" Set ws = Sheets("Status and SLA trends") Set wsTemp = Sheets.Add tp = 10 With wsTemp For Each chrt In ws.Shapes chrt.Copy wsTemp.Range("A1").PasteSpecial Selection.Top = tp Selection.Left = 5 tp = tp + Selection.Height + 50 Next End With wsTemp.ExportAsFixedFormat Type:=xlTypePDF, Filename:=NewFileName, Quality:=xlQualityStandard, _ IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True Application.DisplayAlerts = False wsTemp.Delete LetsContinue: With Application .ScreenUpdating = True .DisplayAlerts = True End With Exit Sub Whoa: MsgBox Err.Description Resume LetsContinue End Sub
[将所有图表导出为一个PDF]这对我有效：我从这里扩展了样本。 它将所有图表复制到一个临时图纸，然后更改页面设置（字母/横向），并调整/重新放置每个图表以适应不同的页面边界。 最后一步是将此表单打印为pdf文档并删除临时表单。
Sub kartinka() Dim i As Long, j As Long, k As Long Dim adH As Long Dim Rng As Range Dim FilePath As String: FilePath = ThisWorkbook.Path & "\" Dim sht As Worksheet, shtSource As Worksheet, wk As Worksheet '=================================================================== '=================================================================== Sheets.Add After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count) ActiveSheet.Name = "ALL" Set sht = ActiveSheet '=================================================================== Application.ScreenUpdating = False '=================================================================== 'Excluding ALL tab, copying all charts from all tabs to ALL For Each wk In Worksheets If wk.Name <> "ALL" Then Application.DisplayAlerts = False j = wk.ChartObjects.Count For i = 1 To j wk.ChartObjects(i).Activate ActiveChart.ChartArea.Copy sht.Select ActiveSheet.Paste sht.Range("A" & 1 + i & "").Select Next i Application.DisplayAlerts = True End If Next '=================================================================== '=================================================================== 'To set the constant cell vertical increment for separate pages adH = 40 k = 0 j = sht.ChartObjects.Count '=================================================================== Application.PrintCommunication = True 'this will allow page settings to update 'To set page margins, adding some info about the file location, tab name and date With ActiveSheet.PageSetup .LeftMargin = Application.InchesToPoints(0.7) .RightMargin = Application.InchesToPoints(0.7) .TopMargin = Application.InchesToPoints(0.75) .BottomMargin = Application.InchesToPoints(0.75) .HeaderMargin = Application.InchesToPoints(0.3) .FooterMargin = Application.InchesToPoints(0.3) .Orientation = xlLandscape .LeftHeader = "Date generated : " & Now .CenterHeader = "" .RightHeader = "File name : " & ActiveWorkbook.Name .LeftFooter = "File location : " & FilePath & ThisWorkbook.Name .CenterFooter = "" .RightFooter = "" .FitToPagesWide = 1 End With '=================================================================== 'adjusting page layout borders sht.VPageBreaks.Add sht.[N1] For i = 40 To j * 40 Step 40 sht.HPageBreaks.Add Before:=sht.Cells(i + 1, 1) Next i Columns("A:A").EntireRow.RowHeight = 12.75 Rows("1:1").EntireColumn.ColumnWidth = 8.43 '=================================================================== For i = 1 To j Set Rng = ActiveSheet.Range("A" & (1 + k * adH) & " :M" & (40 + k * adH) & "") With ActiveSheet.ChartObjects(i) .Height = Rng.Height .Width = Rng.Width .Top = Rng.Top .Left = Rng.Left End With ActiveSheet.PageSetup.PrintArea = "$A$1:$M" & (40 + k * adH) & "" k = k + 1 Next i '=================================================================== ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=FilePath & ActiveWorkbook.Name & "." & ActiveSheet.Name, Quality:=xlQualityMinimum, _ IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False '=================================================================== Application.DisplayAlerts = False ThisWorkbook.Sheets("ALL").Delete Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub