如何使用vba将excel中的多个图导出为单个pdf？

Question

我对VBA是全新的，需要使用vba将多个图表从excel工作簿导出为单个pdf。我知道可以将图表导出为单个pdf或jpgs，但是是否可以使用vba将工作簿中的所有图表转换为一个pdf？任何意见将不胜感激，因为我似乎无法找到我在别处寻找什么。

我的代码到目前为止打印每个图表的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 

Answer 1

最后我刚才导出表到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 

Answer 2

这是你正在尝试？

逻辑：将所有图表复制到Temp Sheet，然后使用Excel的内置工具创建pdf。一旦完成pdf，删除临时表。这将使用vba将多个图从Sheets("Status and SLA trends")导出为单个pdf。

CODE（久经考验的）：

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 

Answer 3

[导出所有图表，一个PDF]这个工作对我说：我从here延长样品。它将所有图表复制到一张临时图纸，然后更改页面设置（字母/横向），并调整/重新定位每个图表以适应不同的页面边界。最后一步是将此工作表打印为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