使用 VBA 将 Excel 图表粘贴到 Powerpoint 中

Paste Excel Chart into Powerpoint using VBA

提问by thedeepfield

I'm trying to create an excel macro that copies charts displayed on an excel sheet, and pastes them (paste special) into a PowerPoint. The problem I'm having is how do I paste each chart on a different slide? I do not know the syntax at all..

我正在尝试创建一个 excel 宏来复制显示在 excel 工作表上的图表，并将它们（特殊粘贴）粘贴到 PowerPoint 中。我遇到的问题是如何将每个图表粘贴到不同的幻灯片上？我根本不知道语法..

This is what I have so far (it works but it only pastes to the first sheet):

这是我到目前为止所拥有的（它有效，但它只粘贴到第一张纸）：

Sub graphics3()

Sheets("Chart1").Select
ActiveSheet.ChartObjects("Chart1").Activate
ActiveChart.ChartArea.Copy
Sheets("Graphs").Select
range("A1").Select
ActiveSheet.Paste
     With ActiveChart.Parent
     .Height = 425 ' resize
     .Width = 645  ' resize
     .Top = 1    ' reposition
     .Left = 1   ' reposition
 End With

Dim PPT As Object
Set PPT = CreateObject("PowerPoint.Application")
PPT.Visible = True
PPT.Presentations.Open Filename:="locationwherepptxis"

Set PPApp = GetObject("Powerpoint.Application")
Set PPPres = PPApp.activepresentation
Set PPSlide = PPPres.slides _
    (PPApp.ActiveWindow.Selection.SlideRange.SlideIndex)

' Copy chart as a picture
ActiveChart.CopyPicture Appearance:=xlScreen, Size:=xlScreen, _
    Format:=xlPicture

' Paste chart
PPSlide.Shapes.Paste.Select

' Align pasted chart
PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True

采纳答案by brettdj

Given I dont have your file locations to work with I have attached a routine below that

鉴于我没有你的文件位置，我在下面附上了一个例程

1. Created a new instance of PowerPoint (late binding, hence the need to define constants for ppViewSlide etc)
2. Loops through each chart in a sheet called Chart1 (as per your example)
3. Adds a new slide
4. Pastes each chart, then repeats

1. 创建了一个新的 PowerPoint 实例（后期绑定，因此需要为 ppViewSlide 等定义常量）
2. 循环遍历名为 Chart1 的工作表中的每个图表（根据您的示例）
3. 添加新幻灯片
4. 粘贴每个图表，然后重复

Did you need to format each chart picture before exporting for size, or can you change your default chart size?

在导出大小之前是否需要格式化每个图表图片，或者您可以更改默认图表大小吗？

Const ppLayoutBlank = 2
Const ppViewSlide = 1

Sub ExportChartstoPowerPoint()
    Dim PPApp As Object
    Dim chr
    Set PPApp = CreateObject("PowerPoint.Application")
    PPApp.Presentations.Add
    PPApp.ActiveWindow.ViewType = ppViewSlide
    For Each chr In Sheets("Chart1").ChartObjects
        PPApp.ActivePresentation.Slides.Add PPApp.ActivePresentation.Slides.Count + 1, ppLayoutBlank
        PPApp.ActiveWindow.View.GotoSlide PPApp.ActivePresentation.Slides.Count
        chr.Select
        ActiveChart.CopyPicture Appearance:=xlScreen, Size:=xlScreen, Format:=xlPicture
        PPApp.ActiveWindow.View.Paste
        PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
        PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True
    Next chr
    PPApp.Visible = True
End Sub

回答by Vinayak K

Code with function for plotting 6 charts from Excel to PPT

具有将 6 个图表从 Excel 绘制到 PPT 的功能的代码

Option Base 1
Public ppApp As PowerPoint.Application

Sub CopyChart()

Dim wb As Workbook, ws As Worksheet
Dim oPPTPres As PowerPoint.Presentation
Dim myPPT As String
myPPT = "C:\LearnPPT\MyPresentation2.pptx"

Set ppApp = CreateObject("PowerPoint.Application")
'Set oPPTPres = ppApp.Presentations("MyPresentation2.pptx")
Set oPPTPres = ppApp.Presentations.Open(Filename:=myPPT)
ppApp.Visible = True
Set wb = ThisWorkbook
Set ws = wb.Sheets(1)

i = 1

For Each shp In ws.Shapes

    strShapename = "C" & i
    ws.Shapes(shp.Name).Name = strShapename
    'shpArray.Add (shp)
    i = i + 1

Next shp

Call Plot6Chart(oPPTPres, 2, ws.Shapes(1), ws.Shapes(2), ws.Shapes(3), ws.Shapes(4), ws.Shapes(5), ws.Shapes(6))

End Sub
Function Plot6Chart(pPres As Presentation, SlideNo As Long, ParamArray cCharts())

Dim oSh As Shape
Dim pSlide As Slide
Dim lLeft As Long, lTop As Long

Application.CutCopyMode = False
Set pSlide = pPres.Slides(SlideNo)

For i = 0 To UBound(cCharts)

    cCharts(i).Copy
    ppApp.ActiveWindow.View.GotoSlide SlideNo
    pSlide.Shapes.Paste
    Application.CutCopyMode = False


    If i = 0 Then ' 1st Chart
        lTop = 0
        lLeft = 0
    ElseIf i = 1 Then ' 2ndChart
        lLeft = lLeft + 240
    ElseIf i = 2 Then ' 3rd Chart
        lLeft = lLeft + 240
    ElseIf i = 3 Then ' 4th Chart
        lTop = lTop + 270
        lLeft = 0
    ElseIf i = 4 Then ' 5th Chart
        lLeft = lLeft + 240
    ElseIf i = 5 Then ' 6th Chart
        lLeft = lLeft + 240
    End If

    pSlide.Shapes(cCharts(i).Name).Left = lLeft
    pSlide.Shapes(cCharts(i).Name).Top = lTop

Next i

Set oSh = Nothing
Set pSlide = Nothing
Set oPPTPres = Nothing
Set ppApp = Nothing
Set pPres = Nothing

End Function