Using VBA to Paste Excel Chart with Data into PowerPoint

问题

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

来源：https://stackoverflow.com/questions/37060831/using-vba-to-paste-excel-chart-with-data-into-powerpoint