使用VBA将Excel图表与数据粘贴到PowerPoint中 [英] Using VBA to Paste Excel Chart with Data into PowerPoint

查看：5450 发布时间：2016/11/20 19:38:25 excel vba charts powerpoint

本文介绍了使用VBA将Excel图表与数据粘贴到PowerPoint中的处理方法，对大家解决问题具有一定的参考价值，需要的朋友们下面随着小编来一起学习吧！

问题描述

答案：TL; DR：粘贴包含嵌入式数据的图表需要很长时间，因此您必须安装延迟，以防止vba在粘贴操作完成之前移动。

问题：我试图将带有嵌入数据的excel图表粘贴到powerpoint演示文稿中。我唯一的事情是挂在ppt一旦它被粘贴和定位的图表。

  Dim newPowerPoint As PowerPoint.Application 
 
 ActiveSheet.ChartObjects（Chart 1）。 b $ b ActiveChart.ChartArea.Copy 
 newPowerPoint.CommandBars.ExecuteMso（PasteExcelChartDestinationTheme）

由于我需要将多个图表粘贴到单张幻灯片中，因此需要重新定位它们。我尝试用这段代码：

  newPowerPoint.ActiveWindow.Selection.ShapeRange.Left = 0

但总是遇到错误：对象'选择'的方法'ShapeRange'失败。

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

我已经尝试过各种方式，我可以想到移动这个图表，但我完全卡住了。有谁知道我怎么能这样做？另外，请记住，图表中必须有数据（我不能将图表粘贴为图片，我强烈希望数据不被链接）。

感谢，

Steve

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

 如果activeSlide.Shapes.Count = 1 then 
 GoTo NextiLoop 
对于其他图表对象，如果

，因为延迟粘贴图2使循环名称图1pptcht2 因为chart2还不存在。

  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 
 
查找现有实例
 On Error Resume Next 
设置newPowerPoint = GetObject（，PowerPoint.Application）
 On Error GoTo 0 
 
'让我们创建一个新的PowerPoint 
如果newPowerPoint是没有然后
设置newPowerPoint =新PowerPoint.Application 
结束如果
 
'在PowerPoint中进行演示
如果newPowerPoint.Presentations.Count = 0然后
 newPowerPoint.Presentations.Add 
结束如果
 
显示PowerPoint 
 newPowerPoint.Visible = True 
 Application.ScreenUpdating = False 
 
'添加一个新幻灯片，我们将在其中粘贴图表
 newPowerPoint.ActivePresentation.Slides.Add _ 
 newPowerPoint.ActivePresentation.Slides.Count + 1，ppLayoutText 
 newPowerPoint.ActiveWindow.View.GotoSlide _ 
 newPowerPoint.ActivePresentation.Slides.Count 
设置activeSlide = newPowerPoint.ActivePresentation.Slides _ 
（newPowerPoint.ActivePresentation.Slides.Count）
 activeSlide.Shapes（1）。删除
 activeSlide.Shapes（1）。删除
 
'ActiveSheet.ChartObjects Chart1）。激活
设置Data = ActiveSheet 
 
设置cht1 = Data.ChartObjects（Share0110）
设置cht2 = Data.ChartObjects（SOW0110）
设置cht3 = Data.ChartObjects（PROP0110）
 
 cht1.Copy 
 
 newPowerPoint.CommandBars.ExecuteMsoPasteExcelChartDestinationTheme
 
 DoEvents 
 
错误时恢复下一个
 Do 
 DoEvents 
设置pptcht1 = activeSlide.Shapes（activeSlide.Shapes.Count）
如果没有pptcht1是Nothing然后退出Do 
 iLoopLimit = iLoopLimit + 1 
如果iLoopLimit> 100然后退出Do 
循环
错误时转到0 
 
 Debug.PrintiLoopLimit =& iLoopLimit 
 
 With pptcht1 
 .Left = 25 
 .Top = 150 
结束于
 
 iLoopLimit = 0 
 
'ActiveSheet.ChartObjects（Chart 2）。激活
'设置Data = ActiveSheet 
 
 cht2.Copy 
 
 newPowerPoint.CommandBars.ExecuteMsoPasteExcelChartDestinationTheme 
 
 DoEvents 
错误恢复下一个
 Do 
 DoEvents 
 
如果activeSlide.Shapes.Count = 1然后
 GoTo NextiLoop 
结束如果
设置pptcht2 = activeSlide.Shapes（activeSlide.Shapes.Count）
如果没有pptcht2是没有然后退出Do 
 NextiLoop：
 iLoopLimit = iLoopLimit + 1 
如果iLoopLimit> 100然后退出Do 
循环
错误时转到0 
 
 Debug.PrintiLoopLimit =& iLoopLimit 
 
 With pptcht2 
 .Left = 275 
 .Top = 150 
结束于
 
 iLoopLimit = 0 
 
 AppActivate（Microsoft PowerPoint）
设置activeSlide =无
设置newPowerPoint =无
 
结束子

编辑：OLD无效代码：

  Sub CreatePPT b 
 $ b Dim newPowerPoint As PowerPoint.Application 
 Dim activeSlide As PowerPoint.Slide 
 Dim cht As Excel.ChartObject 
 
 Application.ScreenUpdating = False 
 
 
查找现有实例
错误恢复下一个
设置newPowerPoint = GetObject（，PowerPoint.Application）
出现错误GoTo 0 
 
'让我们创建一个新的PowerPoint 
如果newPowerPoint是没有然后
设置newPowerPoint =新的PowerPoint.Application 
结束如果
 
'在PowerPoint中进行演示PowerPoint b $ b如果newPowerPoint.Presentations.Count = 0则
 newPowerPoint.Presentations.Add 
结束如果
 
显示PowerPoint 
 newPowerPoint.Visible = True 
 Application.ScreenUpdating = False 
 
'添加一个新的幻灯片，我们将在其中粘贴图表
 newPowerPoint.ActivePresentation.Slides.Add newPowerPoint.ActivePresentation.Slides.Count + 1，ppLayoutText 
 newPowerPoint.ActiveWindow.View.GotoSlide newPowerPoint.ActivePresentation.Slides.Count 
设置activeSlide = newPowerPoint.ActivePresentation.Slides（newPowerPoint.ActivePresentation.Slides.Count）
 activeSlide.Shapes（1）。删除
 activeSlide.Shapes（1）.Delete 
 
 
 
'ActiveSheet.ChartObjects（Chart 1）。激活
设置Data = ActiveSheet 
设置cht1 = Data.ChartObjects（Chart 1）
 cht1.Copy 
 
 newPowerPoint.CommandBars.ExecuteMso（PasteExcelChartDestinationTheme）
 
设置pptcht1 = newPowerPoint .ActiveWindow.Selection 
使用pptcht1 
 .Left = 0 
结束于
 
 
 
 
 AppActivate（Microsoft PowerPoint ）
设置activeSlide =无
设置newPowerPoint =无
 
结束子

解决方案

自己动手，并输入代码模块的第一行：

选项显式

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

将形状声明为PowerPoint.Shape，然后使用此形状，因为任何新添加的形状是最后一个

设置pptcht1 = activeSlide.Shapes（activeSlide.Shapes.Count）

以下行首先不需要括号，尽管写得不好的Microsoft帮助文章。第二，运行需要很长时间。 Excel已经在尝试在形状创建之前移动形状。 DoEvents应该通过使Excel等待，直到计算机上的所有其他事情都完成，但线仍然太慢，帮助这一点。

newPowerPoint.CommandBars.ExecuteMso（PasteExcelChartDestinationTheme）

所以我拼凑了一个小循环，试图

 在错误时恢复下一个
 Do 
 DoEvents 
设置pptcht1 = activeSlide.Shapes（activeSlide.Shapes.Count）
如果没有pptcht1是没有然后退出Do 
 iLoopLimit = iLoopLimit + 1 
如果iLoopLimit > 100然后退出Do 
循环
错误时转到0

的测试，我发现循环将不得不运行20到60次。我也崩溃PowerPoint几次。很奇怪。

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

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

AppActivate（Microsoft PowerPoint）

使用：

AppActivate newPowerPoint.Caption

所以你的整个代码变成：

`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 
 
查找现有实例
出现错误时恢复下一个
设置newPowerPoint = GetObject（，PowerPoint.Application）
出现错误GoTo 0 
 
'让我们创建一个新的PowerPoint 
如果newPowerPoint是没有然后
设置newPowerPoint =新的PowerPoint.Application 
结束如果
 
'在PowerPoint中进行演示
 If newPowerPoint.Presentations.Count = 0 Then 
 newPowerPoint.Presentations.Add 
 End If 
 
'显示PowerPoint 
 newPowerPoint.Visible = True 
 Application.ScreenUpdating = False 
 
'添加一个新的幻灯片，我们将在其中粘贴图表
 newPowerPoint.ActivePresentation.Slides.Add _ 
 newPowerPoint.ActivePresentation.Slides.Count + 1， ppLayoutText 
 newPowerPoint.ActiveWindow.View.GotoSlide _ 
 newPowerPoint.ActivePresentation.Slides.Count 
设置activeSlide = newPowerPoint.ActivePresentation.Slides _ 
（newPowerPoint.ActivePresentation.Slides.Count） 
 activeSlide.Shapes（1）。删除
 activeSlide.Shapes（1）。删除
 
'ActiveSheet.ChartObjects（Chart 1）。激活
设置数据= ActiveSheet 
设置cht1 = Data.ChartObjects（图1）
 cht1.Copy 
 
 newPowerPoint.CommandBars.ExecuteMsoPasteExcelChartDestinationTheme
 
 DoEvents 
 
错误时恢复下一个
 Do 
 DoEvents 
设置pptcht1 = activeSlide.Shapes（activeSlide.Shapes.Count）
如果没有pptcht1是Nothing然后退出Do 
 iLoopLimit = iLoopLimit + 1 
如果iLoopLimit> 100然后退出Do 
循环
错误时转到0 
 
 Debug.PrintiLoopLimit =& iLoopLimit 
 
使用pptcht1 
 .Left = 0 
结束于
 
 AppActivate newPowerPoint.Caption 
设置activeSlide =无
设置newPowerPoint = Nothing 
 
 End Sub`

Answer: TL;DR: pasting a chart with embedded data takes a long time so you have to install a delay to prevent vba from moving on before the paste operation completes.

Question:I'm trying to paste an excel chart with embedded data into a powerpoint presentation. The only thing I am getting hung up on is referring to and positioning the chart in ppt once it has been pasted.

    Dim newPowerPoint As PowerPoint.Application

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

Since I need to paste multiple charts into single slides, repositioning them is necessary. I try to do that with this piece of code:

        newPowerPoint.ActiveWindow.Selection.ShapeRange.Left = 0

but am always met with the error: "Method 'ShapeRange' of object 'Selection' failed".

What's particularly odd is that running the code from start to finish results in this error, but stepping through the code using the F8 key does not.

I have tried every way I can think of to move this chart around but I am totally stuck. Does anyone know how I can do this? Also, please keep in mind that is necessary that the chart have data in it (I can't paste the chart as a picture and I would strongly prefer that the data not be linked).

Thanks,

Steve

edit new modified code with multiple chart objects. I needed to add an if conditional:

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

for additional chart objects because the delay pasting chart 2 makes the loop name chart 1 "pptcht2" since chart2 did not exist yet.

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

edit: OLD not working code:

    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

解决方案

Do yourself a favor and enter this as the first line of the code module:

Option Explicit

This will force you to declare all variables. You have a lot of undeclared variables, including a couple that are almost the same as the few you did declare. Then go to VBA's Tools menu > Options, and check the Require Variable Declaration on the first tab of the dialog, which will put Option Explicit at the top of every new module.

Declare the shape as a PowerPoint.Shape, then find it using this, since any newly added shape is the last one on the slide:

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

The following line first of all does not need the parentheses, despite the poorly written Microsoft Help article. Second, it takes a long time to run. Excel is already trying to move the shape long before the shape has been created. DoEvents is supposed to help with this by making Excel wait until everything else happening on the computer is finished, but the line is still too slow.

newPowerPoint.CommandBars.ExecuteMso ("PasteExcelChartDestinationTheme")

So I cobbled together a little loop that tries to set the variable to the shape, and keeps looping until the shape is finished being created.

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

In a small number of tests, I found that the loop would have to run 20 to 60 times. I also crashed PowerPoint a few times. Weird.

I'm sure there are better ways to paste the copied chart and keep the slide's color theme, but off the top of my head I don't know one.

This is unreliable, since the application caption changes with different versions of Office (and again the parentheses are not needed):

AppActivate ("Microsoft PowerPoint")

Use this instead:

AppActivate newPowerPoint.Caption

So your whole code becomes:

` 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`

这篇关于使用VBA将Excel图表与数据粘贴到PowerPoint中的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！

查看全文

使用VBA将Excel图表与数据粘贴到PowerPoint中 [英] Using VBA to Paste Excel Chart with Data into PowerPoint

问题描述

相关文章

其他开发最新文章

热门教程

热门工具

登录关闭

使用VBA将Excel图表与数据粘贴到PowerPoint中 [英] Using VBA to Paste Excel Chart with Data into PowerPoint

问题描述

相关文章

其他开发最新文章

热门教程

热门工具

登录 关闭

登录关闭