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

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

这是我到目前为止（它的工作原理，但只贴到第一张）：

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 

Answer 1

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

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

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

 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 

Answer 2

具有从Excel到PPT绘制6个图表function的代码

 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