pastespecial的对象形状失败vba
我有这个代码将Excel 2010工作表中的图表复制到PowerPoint中。 它循环search活动工作表上的所有图表,然后将链接复制并粘贴到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
原因很简单。 您没有足够的时间将Excel复制到剪贴板。
尝试这个
ActiveChart.ChartArea.Copy DoEvents activeSlide.Shapes.PasteSpecial(Link:=True).Select
你也可以试试这个,它对我有用,如果不是增加秒数,看看(不是1秒,对我来说它工作了2秒)谢谢,赛义德。
ActiveChart.ChartArea.Copy Application.Wait Now + TimeValue("00:00:01") activeSlide.Shapes.PasteSpecial(Link:=True).Select