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

选项显式

这将强制您声明所有变量.你有很多未声明的变量，包括一些几乎与你声明的几个相同的变量.然后转到 VBA 的工具菜单 > 选项，并检查对话框第一个选项卡上的需要变量声明，这会将 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.

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

设置pptcht1 = activeSlide.Shapes(activeSlide.Shapes.Count)

1. 以下行首先不需要括号，尽管 Microsoft 帮助文章写得很糟糕.其次，运行时间长.早在创建形状之前，Excel 就已经在尝试移动该形状.DoEvents 应该可以帮助解决这个问题，让 Excel 等待计算机上发生的所有其他事情完成，但线路仍然太慢.

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

在少数测试中，我发现循环必须运行 20 到 60 次.我也几次使 PowerPoint 崩溃.奇怪.

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.

1. 这是不可靠的，因为应用程序标题随 Office 的不同版本而变化(同样不需要括号):

AppActivate(Microsoft PowerPoint")

改用这个:

AppActivate newPowerPoint.Caption

1. 所以你的整个代码变成:

` 子 CreatePPT()

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