使用VBA将Excel图表与数据粘贴到PowerPoint中

答案：TL; DR：粘贴带有embedded数据的图表需要很长时间，所以您必须安装一个延迟来防止vba在粘贴操作完成之前继续。

问题：我试图将一个带embedded数据的Excel图表粘贴到PowerPoint演示文稿中。 唯一让我挂在嘴边的是一旦它被粘贴，就把这个图表定位在ppt中。

Dim newPowerPoint As PowerPoint.Application ActiveSheet.ChartObjects("Chart 1").Activate ActiveChart.ChartArea.Copy newPowerPoint.CommandBars.ExecuteMso ("PasteExcelChartDestinationTheme") 

由于我需要将多个图表粘贴到单个幻灯片中，因此重新定位它们是必要的。 我试图用这段代码来做到这一点：

  newPowerPoint.ActiveWindow.Selection.ShapeRange.Left = 0 

但总是遇到错误：“对象'select'的方法'ShapeRange'失败”。

特别奇怪的是，从开始到结束运行代码都会导致这个错误，但是使用F8键代码不会执行。

我已经想尽一切办法来移动这个图表，但我完全陷入困境。 有谁知道我怎么能做到这一点？ 此外，请记住，图表有数据是必要的（我不能粘贴图表作为图片，我强烈希望数据不被链接）。

谢谢，

史蒂夫

用多个图表对象编辑新的修改后的代码。 我需要添加一个if条件：

 If activeSlide.Shapes.Count = 1 Then GoTo NextiLoop End If 

对于附加的图表对象，因为延迟粘贴图2使得循环名称图1“pptcht2”，因为图表2还不存在。

 Sub CreatePPT() Dim newPowerPoint As PowerPoint.Application Dim activeSlide As PowerPoint.Slide Dim cht1 As Excel.ChartObject Dim Data As Excel.Worksheet Dim pptcht1 As PowerPoint.Shape Dim iLoopLimit As Long Application.ScreenUpdating = False 'Look for existing instance On Error Resume Next Set newPowerPoint = GetObject(, "PowerPoint.Application") On Error GoTo 0 'Let's create a new PowerPoint If newPowerPoint Is Nothing Then Set newPowerPoint = New PowerPoint.Application End If 'Make a presentation in PowerPoint If newPowerPoint.Presentations.Count = 0 Then newPowerPoint.Presentations.Add End If 'Show the PowerPoint newPowerPoint.Visible = True Application.ScreenUpdating = False 'Add a new slide where we will paste the chart newPowerPoint.ActivePresentation.Slides.Add _ newPowerPoint.ActivePresentation.Slides.Count + 1, ppLayoutText newPowerPoint.ActiveWindow.View.GotoSlide _ newPowerPoint.ActivePresentation.Slides.Count Set activeSlide = newPowerPoint.ActivePresentation.Slides _ (newPowerPoint.ActivePresentation.Slides.Count) activeSlide.Shapes(1).Delete activeSlide.Shapes(1).Delete 'ActiveSheet.ChartObjects("Chart 1").Activate Set Data = ActiveSheet Set cht1 = Data.ChartObjects("Share0110") Set cht2 = Data.ChartObjects("SOW0110") Set cht3 = Data.ChartObjects("PROP0110") cht1.Copy newPowerPoint.CommandBars.ExecuteMso "PasteExcelChartDestinationTheme" DoEvents On Error Resume Next Do DoEvents Set pptcht1 = activeSlide.Shapes(activeSlide.Shapes.Count) If Not pptcht1 Is Nothing Then Exit Do iLoopLimit = iLoopLimit + 1 If iLoopLimit > 100 Then Exit Do Loop On Error GoTo 0 Debug.Print "iLoopLimit = " & iLoopLimit With pptcht1 .Left = 25 .Top = 150 End With iLoopLimit = 0 'ActiveSheet.ChartObjects("Chart 2").Activate 'Set Data = ActiveSheet cht2.Copy newPowerPoint.CommandBars.ExecuteMso "PasteExcelChartDestinationTheme" DoEvents On Error Resume Next Do DoEvents If activeSlide.Shapes.Count = 1 Then GoTo NextiLoop End If Set pptcht2 = activeSlide.Shapes(activeSlide.Shapes.Count) If Not pptcht2 Is Nothing Then Exit Do NextiLoop: iLoopLimit = iLoopLimit + 1 If iLoopLimit > 100 Then Exit Do Loop On Error GoTo 0 Debug.Print "iLoopLimit = " & iLoopLimit With pptcht2 .Left = 275 .Top = 150 End With iLoopLimit = 0 AppActivate ("Microsoft PowerPoint") Set activeSlide = Nothing Set newPowerPoint = Nothing End Sub 

编辑：老不工作的代码：

  Sub CreatePPT() Dim newPowerPoint As PowerPoint.Application Dim activeSlide As PowerPoint.Slide Dim cht As Excel.ChartObject Application.ScreenUpdating = False 'Look for existing instance On Error Resume Next Set newPowerPoint = GetObject(, "PowerPoint.Application") On Error GoTo 0 'Let's create a new PowerPoint If newPowerPoint Is Nothing Then Set newPowerPoint = New PowerPoint.Application End If 'Make a presentation in PowerPoint If newPowerPoint.Presentations.Count = 0 Then newPowerPoint.Presentations.Add End If 'Show the PowerPoint newPowerPoint.Visible = True Application.ScreenUpdating = False 'Add a new slide where we will paste the chart newPowerPoint.ActivePresentation.Slides.Add newPowerPoint.ActivePresentation.Slides.Count + 1, ppLayoutText newPowerPoint.ActiveWindow.View.GotoSlide newPowerPoint.ActivePresentation.Slides.Count Set activeSlide = newPowerPoint.ActivePresentation.Slides(newPowerPoint.ActivePresentation.Slides.Count) activeSlide.Shapes(1).Delete activeSlide.Shapes(1).Delete 'ActiveSheet.ChartObjects("Chart 1").Activate Set Data = ActiveSheet Set cht1 = Data.ChartObjects("Chart 1") cht1.Copy newPowerPoint.CommandBars.ExecuteMso ("PasteExcelChartDestinationTheme") Set pptcht1 = newPowerPoint.ActiveWindow.Selection With pptcht1 .Left = 0 End With AppActivate ("Microsoft PowerPoint") Set activeSlide = Nothing Set newPowerPoint = Nothing End Sub 

Answer 1

1. 帮你一个忙，把它作为代码模块的第一行：

Option Explicit

这将迫使你声明所有的variables。 你有很多未声明的variables，其中包括几个与你声明的几个几乎相同的variables。 然后进入VBA的工具菜单>选项，并在对话框的第一个选项卡上检查需要variables声明，这将把Option Explicit放在每个新模块的顶部。

2. 将形状声明为PowerPoint.Shape，然后使用它来find它，因为任何新添加的形状都是幻灯片中的最后一个：

Set pptcht1 = activeSlide.Shapes(activeSlide.Shapes.Count)

3. 下面的代码首先不需要括号，尽pipe写得不好的Microsoft帮助文章。 其次，运行需要很长时间。 在创build形状之前，Excel已经试图移动该形状。 DoEvents应该通过让Excel等待，直到计算机上发生的所有事情都完成了，但是这行仍然太慢。

newPowerPoint.CommandBars.ExecuteMso ("PasteExcelChartDestinationTheme")

所以我拼凑了一个循环，试图将variables设置为形状，并保持循环，直到形状完成创build。

 On Error Resume Next Do DoEvents Set pptcht1 = activeSlide.Shapes(activeSlide.Shapes.Count) If Not pptcht1 Is Nothing Then Exit Do iLoopLimit = iLoopLimit + 1 If iLoopLimit > 100 Then Exit Do Loop On Error GoTo 0 

在less数testing中，我发现循环将运行20到60次。 我也崩溃了几次PowerPoint。 奇怪的。

我相信有更好的方法来粘贴复制的图表，并保持幻灯片的颜色主题，但我的头顶我不知道。

4. 这是不可靠的，因为应用程序标题随不同版本的Office而改变（并且不需要括号）：

AppActivate ("Microsoft PowerPoint")

用这个代替：

AppActivate newPowerPoint.Caption

5. 所以你的整个代码变成：

Sub CreatePPT（）

  Dim newPowerPoint As PowerPoint.Application Dim activeSlide As PowerPoint.Slide Dim cht1 As Excel.ChartObject Dim Data As Excel.Worksheet Dim pptcht1 As PowerPoint.Shape Dim iLoopLimit As Long Application.ScreenUpdating = False 'Look for existing instance On Error Resume Next Set newPowerPoint = GetObject(, "PowerPoint.Application") On Error GoTo 0 'Let's create a new PowerPoint If newPowerPoint Is Nothing Then Set newPowerPoint = New PowerPoint.Application End If 'Make a presentation in PowerPoint If newPowerPoint.Presentations.Count = 0 Then newPowerPoint.Presentations.Add End If 'Show the PowerPoint newPowerPoint.Visible = True Application.ScreenUpdating = False 'Add a new slide where we will paste the chart newPowerPoint.ActivePresentation.Slides.Add _ newPowerPoint.ActivePresentation.Slides.Count + 1, ppLayoutText newPowerPoint.ActiveWindow.View.GotoSlide _ newPowerPoint.ActivePresentation.Slides.Count Set activeSlide = newPowerPoint.ActivePresentation.Slides _ (newPowerPoint.ActivePresentation.Slides.Count) activeSlide.Shapes(1).Delete activeSlide.Shapes(1).Delete 'ActiveSheet.ChartObjects("Chart 1").Activate Set Data = ActiveSheet Set cht1 = Data.ChartObjects("Chart 1") cht1.Copy newPowerPoint.CommandBars.ExecuteMso "PasteExcelChartDestinationTheme" DoEvents On Error Resume Next Do DoEvents Set pptcht1 = activeSlide.Shapes(activeSlide.Shapes.Count) If Not pptcht1 Is Nothing Then Exit Do iLoopLimit = iLoopLimit + 1 If iLoopLimit > 100 Then Exit Do Loop On Error GoTo 0 Debug.Print "iLoopLimit = " & iLoopLimit With pptcht1 .Left = 0 End With AppActivate newPowerPoint.Caption Set activeSlide = Nothing Set newPowerPoint = Nothing End Sub`