对象形状的特殊粘贴失败，vba

Question

我有这段代码可将图表从Excel 2010工作表复制到PowerPoint中。它会循环搜索活动工作表上的所有图表，然后将链接复制并粘贴到Powerpoint中。还有一小段代码，其中包含图表标题并将其作为标题放入PowerPoint。

[在大多数情况下，它对我来说效果很好，但是它给了我一个运行时错误-2147467259（80004005）将9个图表移入Powerpoint后，对象'Shapes'的方法'PasteSpecial'失败。是什么原因导致完美运行期间出现此故障？

Sub CreatePowerPoint()

 'Add a reference to the Microsoft PowerPoint Library by:

    Dim newPowerPoint As PowerPoint.Application
    Dim activeSlide As PowerPoint.Slide
    Dim cht As Excel.ChartObject

 '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

'Loop through each chart in the Excel worksheet and paste them into the PowerPoint
    For Each cht In ActiveSheet.ChartObjects

    '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)

    'Copy the chart and paste it into the PowerPoint
        cht.Select
        ActiveChart.ChartArea.Copy
        activeSlide.Shapes.PasteSpecial(Link:=True).Select

    'Set the title of the slide the same as the title of the chart
        If ActiveChart.HasTitle = True Then
            activeSlide.Shapes(1).TextFrame.TextRange.Text = cht.Chart.ChartTitle.Text
        Else
            activeSlide.Shapes(1).TextFrame.TextRange.Text = "Add Title"
        End If
    'Adjust the positioning of the Chart on Powerpoint Slide
        newPowerPoint.ActiveWindow.Selection.ShapeRange.Left = 0.5 * 72
        newPowerPoint.ActiveWindow.Selection.ShapeRange.Top = 1.75 * 72
        newPowerPoint.ActiveWindow.Selection.ShapeRange.LockAspectRatio = msoFalse
        newPowerPoint.ActiveWindow.Selection.ShapeRange.Height = 5.5 * 72
        newPowerPoint.ActiveWindow.Selection.ShapeRange.Width = 8.92 * 72

       Next

AppActivate ("Microsoft PowerPoint")
Set activeSlide = Nothing
Set newPowerPoint = Nothing

End Sub

Answer 1

原因很简单。您没有给Excel足够的时间将图表复制到剪贴板。

尝试一下

    ActiveChart.ChartArea.Copy
    DoEvents
    activeSlide.Shapes.PasteSpecial(Link:=True).Select 

Answer 2

[您也可以尝试一下，它对我有用，如果不增加秒数，可以看到（不是1秒，对我来说它可以工作2秒。）谢谢，Syed。

ActiveChart.ChartArea.Copy
Application.Wait Now + TimeValue("00:00:01")
activeSlide.Shapes.PasteSpecial(Link:=True).Select 

Answer 3

非常好！没有Stackoverflow怎么办？

With Sheets（“步骤2-GE被消除”）'粘贴到Step2表格中.Cells（2，i * 4）。选择Application.Wait Now + TimeValue（“ 00：00：001”）'来自Stackoverflow的这一行。ActiveSheet.Paste结尾为