4

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

在大多数情况下，它对我来说非常有效，但是它给了我一个运行时错误 -2147467259 (80004005) 对象“形状”的方法“PasteSpecial”在将 9 个图表移入 powerpoint 后失败。在完美运行过程中可能导致此故障的原因是什么？

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
4

3 回答 3

4

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

尝试这个

    ActiveChart.ChartArea.Copy
    DoEvents
    activeSlide.Shapes.PasteSpecial(Link:=True).Select
于 2013-10-04T16:44:25.047 回答
0

你也可以试试这个，它对我有用，如果不增加秒数，看看（不是 1 秒，对我来说它工作了 2 秒。）谢谢，Syed。

ActiveChart.ChartArea.Copy
Application.Wait Now + TimeValue("00:00:01")
activeSlide.Shapes.PasteSpecial(Link:=True).Select
于 2014-08-07T17:05:46.020 回答
0

出色的！没有 Stackoverflow 我该怎么办？

With Sheets("Step 2- GEs Eliminated") '粘贴到 Step2 sheet .Cells(2, i * 4).Select Application.Wait Now + TimeValue("00:00:001") '这行来自 Stackoverflow。ActiveSheet.Paste 结束于

于 2020-05-01T08:55:06.647 回答