excel - 使用 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

但我总是遇到错误:“对象'Selection'的方法'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

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

Option Explicit
这将强制您声明所有变量。你有很多未声明的变量，包括几个几乎与你声明的少数相同的变量。然后转到 VBA 的工具菜单 > 选项，并检查对话框第一个选项卡上的 Require Variable Declaration，它将放置 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

所以你的整个代码变成:

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