使用VBA从Excel复制到一个开放的Powerpoint演示文稿

我知道这个问题以前是以类似的方式提出的，但是我对编码很陌生，而且我发现很难理解其他一些职位使用的语言。

• 本质上，任务是将一行数据从一个Excel电子表格复制到另一个从该单行创build图表。

• 它总共创build了6个图表，这些都需要被复制到一个幻灯片演示文稿，其中4个幻灯片，其他2个。

• 然后代码应该循环回到开始，并再次开始该过程，但是下一行数据粘贴到这个迭代的结果为2个新的幻灯片。

我已经设法编写足够的代码，将excel中的数据转换为图表，然后将其导出到PowerPoint，但它总是复制到一个新的PowerPoint演示文稿，而不是一个新的幻灯片，我需要它复制到一个活动的演示文稿。 这里是代码：

Sub Tranposer() ' ' Tranposer Macro ' Copies and Transposes answers to the graph calculator ' ' Keyboard Shortcut: Ctrl+h ' Windows("Data Spreadsheet.xlsx").Activate Rows("2:2").Select Selection.Copy Windows("Graph Spreadsheet.xlsm").Activate Range("B1").Select Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _ False, Transpose:=True Dim PowerPointApp As PowerPoint.Application Dim myPresentation As PowerPoint.Presentation Dim mySlide As PowerPoint.Slide Dim myShapeRange As PowerPoint.Shape 'Create an Instance of PowerPoint On Error Resume Next 'Is PowerPoint already opened? Set PPApp = GetObject(, "Powerpoint.Application") Set PPPres = PPApp.ActivePresentation Set PowerPointApp = GetObject(class:="PowerPoint.Application") 'Clear the error between errors Err.Clear 'If PowerPoint is not already open then open PowerPoint If PowerPointApp Is Nothing Then Set PowerPointApp = CreateObject(class:="PowerPoint.Application") 'Handle if the PowerPoint Application is not found If Err.Number = 429 Then MsgBox "PowerPoint could not be found, aborting." Exit Sub End If On Error GoTo 0 'Make PowerPoint Visible and Active PowerPointApp.Visible = True PowerPointApp.Activate 'Create a New Presentation Set myPresentation = PowerPointApp.Presentations.Add 'Add a slide to the Presentation Set mySlide = myPresentation.Slides.Add(1, ppLayoutTitleOnly) 'Copy Excel Range ActiveSheet.ChartObjects("Chart 1").Activate ActiveChart.ChartArea.Copy 'Paste to PowerPoint and position mySlide.Shapes.PasteSpecial DataType:=ppPasteEnhancedMetafile 'Copy Excel Range ActiveSheet.ChartObjects("Chart 7").Activate ActiveChart.ChartArea.Copy 'Paste to PowerPoint and position mySlide.Shapes.PasteSpecial DataType:=ppPasteEnhancedMetafile 'Copy Excel Range ActiveSheet.ChartObjects("Chart 5").Activate ActiveChart.ChartArea.Copy 'Paste to PowerPoint and position mySlide.Shapes.PasteSpecial DataType:=ppPasteEnhancedMetafile 'Copy Excel Range ActiveSheet.ChartObjects("Chart 4").Activate ActiveChart.ChartArea.Copy 'Paste to PowerPoint and position mySlide.Shapes.PasteSpecial DataType:=ppPasteEnhancedMetafile 'Copy Excel Range ActiveSheet.ChartObjects("Chart 6").Activate ActiveChart.ChartArea.Copy 'Paste to PowerPoint and position mySlide.Shapes.PasteSpecial DataType:=ppPasteEnhancedMetafile 'Copy Excel Range ActiveSheet.ChartObjects("Chart 9").Activate ActiveChart.ChartArea.Copy 'Paste to PowerPoint and position mySlide.Shapes.PasteSpecial DataType:=ppPasteEnhancedMetafile 'Clear The Clipboard Application.CutCopyMode = False End Sub 

我知道这是很多的代码，我知道我可以通过图表循环保存时间，但我不知道如何循环，所以我现在很自然的离开，这是怎么回事。 任何人都可以帮助我出口到PowerPoint？

Answer 1

如果我理解的很好，可以循环selectData Spreadsheet的下一行，将其复制/粘贴到Graph Spreadsheet ，然后将每行的6个图表（在2张幻灯片上）粘贴到同一个表示中。

这里是你的代码审查做到这一点（修改/选项下面的代码）：

 Sub Tranposer() ' ' Tranposer Macro ' Copies and Transposes answers to the graph calculator ' ' Keyboard Shortcut: Ctrl+h ' Dim PowerPointApp As PowerPoint.Application, _ myPresentation As PowerPoint.Presentation, _ mySlide As PowerPoint.Slide, _ myShapeRange As PowerPoint.Shape, _ WsData As Worksheet, _ WsGraph As Worksheet Set WsData = Workbooks("Data Spreadsheet.xlsx").ActiveSheet Set WsGraph = Workbooks("Graph Spreadsheet.xlsm").ActiveSheet On Error Resume Next 'Is PowerPoint already opened? Set PPApp = GetObject(, "Powerpoint.Application") Set PPPres = PPApp.ActivePresentation Set PowerPointApp = GetObject(class:="PowerPoint.Application") 'Clear the error between errors Err.Clear 'If PowerPoint is not already open then open PowerPoint If PowerPointApp Is Nothing Then Set PowerPointApp = CreateObject(class:="PowerPoint.Application") 'Handle if the PowerPoint Application is not found If Err.Number = 429 Then MsgBox "PowerPoint could not be found, aborting." Exit Sub End If On Error GoTo 0 'Make PowerPoint Visible and Active PowerPointApp.Visible = True PowerPointApp.Activate 'Create a New Presentation 'Set myPresentation = PowerPointApp.Presentations.Add 'Or Open an EXISTING one Set myPresentation = PowerPointApp.Presentations.Open("C:\Test\Ppt_Test.pptx") 'Add a slide to the Presentation Set mySlide = myPresentation.Slides.Add(myPresentation.Slides.Count, ppLayoutTitleOnly) For i = 2 To 5 'WsData.Range("A" & WsData.Rows.Count).End(xlUp).Row WsData.Rows(i & ":" & i).Copy WsGraph.Range("B1").PasteSpecial Paste:=xlPasteAll, _ Operation:=xlNone, _ SkipBlanks:=False, _ Transpose:=True 'Copy Excel Range WsGraph.ChartObjects("Chart 1").ChartArea.Copy 'Paste to PowerPoint and position mySlide.Shapes.PasteSpecial DataType:=ppPasteEnhancedMetafile 'Copy Excel Range WsGraph.ChartObjects("Chart 7").ChartArea.Copy 'Paste to PowerPoint and position mySlide.Shapes.PasteSpecial DataType:=ppPasteEnhancedMetafile 'Copy Excel Range WsGraph.ChartObjects("Chart 5").ChartArea.Copy 'Paste to PowerPoint and position mySlide.Shapes.PasteSpecial DataType:=ppPasteEnhancedMetafile 'Copy Excel Range WsGraph.ChartObjects("Chart 4").ChartArea.Copy 'Paste to PowerPoint and position mySlide.Shapes.PasteSpecial DataType:=ppPasteEnhancedMetafile 'Add a new slide Set mySlide = myPresentation.Slides.Add(myPresentation.Slides.Count, ppLayoutTitleOnly) 'Copy Excel Range WsGraph.ChartObjects("Chart 6").ChartArea.Copy 'Paste to PowerPoint and position mySlide.Shapes.PasteSpecial DataType:=ppPasteEnhancedMetafile 'Copy Excel Range WsGraph.ChartObjects("Chart 9").ChartArea.Copy 'Paste to PowerPoint and position mySlide.Shapes.PasteSpecial DataType:=ppPasteEnhancedMetafile Next i 'Clear The Clipboard Application.CutCopyMode = False 'Set = Nothing : Free named Object-variables Set PPApp = Nothing Set PPPres = Nothing Set PowerPointApp = Nothing Set myPresentation = Nothing Set mySlide = Nothing Set WsData = Nothing Set WsGraph = Nothing End Sub 

首先，您需要在这里指定工作表的名称Set WsData = Workbooks("Data Spreadsheet.xlsx").ActiveSheet ，像这样Set WsData = Workbooks("Data Spreadsheet.xlsx").Sheets("Sheet_Name") 。

然后，您可以使用Set myPresentation = PowerPointApp.Presentations.Add创build一个新的演示文稿，或者使用Set myPresentation = PowerPointApp.Presentations.Open("C:\Test\Ppt_Test.pptx")打开一个Set myPresentation = PowerPointApp.Presentations.Open("C:\Test\Ppt_Test.pptx") 。

对于循环来说，目前它被设置为在Data Spreadsheet从第2行循环到第5行， For i = 2 To 5 ，但是可以通过清除5来循环到最后一行数据并将其replace为WsData.Range("A" & WsData.Rows.Count).End(xlUp).Row

最后，不要忘记通过将它们设置为Nothing来释放对象variables。

顺便说一句，我摆脱了无用的Select和Activate ，这是非常贪婪的资源几乎没有什么大部分时间。