可以将文章内容翻译成中文,广告屏蔽插件可能会导致该功能失效(如失效，请关闭广告屏蔽插件后再试):

问题:

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

回答1:

Do yourself a favor and enter this as the first line of the code module:

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.

Declare the shape as a PowerPoint.Shape, then find it using this, since any newly added shape is the last one on the slide:

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

The following line first of all does not need the parentheses, despite the poorly written Microsoft Help article. Second, it takes a long time to run. Excel is already trying to move the shape long before the shape has been created. DoEvents is supposed to help with this by making Excel wait until everything else happening on the computer is finished, but the line is still too slow.

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

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.

This is unreliable, since the application caption changes with different versions of Office (and again the parentheses are not needed):

AppActivate ("Microsoft PowerPoint")

Use this instead:

AppActivate newPowerPoint.Caption

So your whole code becomes:

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

文章来源: Using VBA to Paste Excel Chart with Data into PowerPoint

标签

chart

powerpoint

vba