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

这是你在尝试的吗？

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

代码（经过测试和测试）：

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 doc并删除临时表。

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

如何使用vba将多个图表从excel导出到单个pdf？

3 个答案: