PDA

View Full Version : Run-Time 1004 Array Copy Error Charts to PPT



Sphinx404
07-16-2018, 09:41 AM
I am having a problem that I've been trying to figure out for 4 days now and I have no idea what is going on. I've triple checked everything and I cannot for the life of me figure out why I'm getting the run-time 1004 error. I don't know where else to turn.

the following code:


Sub SCOM_Charts1()


ActiveSheet.Shapes.Range(Array("Object 4")).Select
Selection.Verb Verb:=3


If Not Application.CalculationState = xlDone Then DoEvents
Application.CalculateUntilAsyncQueriesDone


Dim acslide As Slide
Dim myPresentation As Object, mySlide As Object, PowerPointApp As Object, shp As Object
Dim MySlideArray As Variant, MyChartArray As Variant, X As Long, ns%


Application.ScreenUpdating = False


On Error Resume Next
Set PowerPointApp = GetObject(class:="PowerPoint.Application")
Err.Clear


If PowerPointApp Is Nothing Then
MsgBox "PowerPoint Presentation is not open, action aborted."
Exit Sub
End If


If Err.Number = 429 Then
MsgBox "PowerPoint could not be found, action aborted."
Exit Sub
End If
On Error GoTo 0


PowerPointApp.ActiveWindow.Panes(2).Activate


Set myPresentation = PowerPointApp.ActivePresentation


MySlideArray = Array(2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15)


MyChartArray = Array(Sheet2.ChartObjects("Assy1"), Sheet2.ChartObjects("Assy2"), Sheet2.ChartObjects("Assy4"), Sheet2.ChartObjects("Assy7"), Sheet2.ChartObjects("Assy8"), Sheet1.ChartObjects("Velocity2"), _
Sheet1.ChartObjects("Velocity1"), Sheet1.ChartObjects("Velocity4"), Sheet1.ChartObjects("Velocity3"), Sheet4.ChartObjects("Free1"), Sheet4.ChartObjects("Free2"), Sheet4.ChartObjects("Free3"), _
Sheet4.ChartObjects("Free4"), Sheet5.ChartObjects("Assigned1"), Sheet3.ChartObjects("RTY1"))


For X = LBound(MySlideArray) To UBound(MySlideArray)
MyChartArray(X).Copy - ERRORS OUT HERE
DoEvents
Set acslide = myPresentation.Slides(MySlideArray(X))
ns = acslide.Shapes.Count
Set shp = acslide.Shapes.PasteSpecial
JustDoIt ns + 1
On Error Resume Next
shp.LinkFormat.BreakLink
On Error GoTo 0
Application.CutCopyMode = False
Next


Application.ScreenUpdating = True
Application.DisplayAlerts = True
ThisWorkbook.Activate
MsgBox "Export to PowerPoint complete. Note: **All slides will be lost when this workbook is closed.**"
End Sub
Sub JustDoIt(I%)


Dim pptcht1 As PowerPoint.Shape, cnt%
On Error Resume Next
cnt = 0
Do
DoEvents
Set pptcht1 = acslide.Shapes(I)
If Not pptcht1 Is Nothing Then Exit Do
cnt = cnt + 1
If cnt > 100 Then Exit Do
Loop
Debug.Print cnt
On Error GoTo 0


End Sub


Craps out after it copies either slide #2 and sometimes #3.

I just don't understand it. Why oh why! For the love of Santa Claus, please help me!

georgiboy
07-17-2018, 06:29 AM
If you simplify the code (I will paste below) you will see it works just fine, from reading through the code i believe the issue is that one of your chart names/sheets or slide numbers are wrong. When it debugs you may by hovering the mouse over the yellow writing be able to figure out which chart or slide it cannot find.

Also you have 14 slides and 15 charts.


MySlideArray = Array(1, 2)
MyChartArray = Array(Sheet1.ChartObjects("Chart 1"), Sheet2.ChartObjects("Chart 1"))

For X = LBound(MySlideArray) To UBound(MySlideArray)

MyChartArray(X).Copy ' - ERRORS OUT HERE
DoEvents
Set acslide = myPresentation.Slides(MySlideArray(X))
ns = acslide.Shapes.Count
Set shp = acslide.Shapes.PasteSpecial
JustDoIt ns + 1
On Error Resume Next
shp.LinkFormat.BreakLink
On Error GoTo 0
Application.CutCopyMode = False
Next

Hope this helps