如何使用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