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

但我總是遇到錯誤：“對象'選擇'的方法'ShapeRange'失敗”。

特別奇怪的是，從頭到尾運行代碼會導致此錯誤，但使用 F8 鍵單步執行代碼不會。

我已經嘗試了所有我能想到的方法來移動這張圖表，但我完全被卡住了。 有誰知道我怎么能做到這一點？ 另外，請記住，圖表中必須包含數據（我無法將圖表粘貼為圖片，我強烈希望不要鏈接數據）。

謝謝，

史蒂夫

使用多個圖表對象編輯新的修改代碼。 我需要添加一個 if 條件：

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

對於其他圖表對象，因為圖表 2 的延遲粘貼圖表 1 使循環名稱圖表 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

這將強制您聲明所有變量。 你有很多未聲明的變量，包括一些幾乎與你聲明的幾個相同的變量。 然后轉到 VBA 的工具菜單 > 選項，並檢查對話框第一個選項卡上的需要變量聲明，這會將Option Explicit放在每個新模塊的頂部。

2. 將形狀聲明為 PowerPoint.Shape，然后使用它找到它，因為任何新添加的形狀都是幻燈片上的最后一個：

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

3. 盡管 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。 奇怪。

我確信有更好的方法來粘貼復制的圖表並保留幻燈片的顏色主題，但我不知道有什么方法。

4. 這是不可靠的，因為應用程序標題隨 Office 的不同版本而變化（同樣不需要括號）：

AppActivate ("Microsoft PowerPoint")

改用這個：

AppActivate newPowerPoint.Caption

5. 所以你的整個代碼變成：

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