使用 VBA 将包含数据的 Excel 图表粘贴到 PowerPoint 中

Question

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

问题：我正在尝试将带有嵌入数据的 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

但我总是遇到错误："Method 'ShapeRange' of object 'Selection' failed"。

特别奇怪的是，运行代码从开始到结束都会导致此错误，但使用 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

帮自己一个忙，将此作为代码模块的第一行输入：

Option Explicit

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

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

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

下面一行首先不需要括号，尽管 Microsoft 帮助文章写得不好。二是运行耗时较长。 Excel 早在形状创建之前就已经在尝试移动该形状。 DoEvents 应该通过让 Excel 等到计算机上发生的所有其他事情都完成来帮助解决这个问题，但线路仍然太慢。

newPowerPoint.CommandBars.ExecuteMso ("PasteExcelChartDestinationTheme")

所以我拼凑了一个小循环，试图将变量设置为形状，并一直循环直到形状创建完成。

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

在少量测试中，我发现循环要运行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

  '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 中

Using VBA to Paste Excel Chart with Data into PowerPoint

excel

charts

powerpoint

vba