Excel VBA to PPT, Code Just Copies Same Chart Over and Over

[Sphinx404]

So, the title is a tad misleading.... It does copy a few of the right charts into power point without duplicating... Then it will randomly get to a certain chart and copy that chart 2 or 3 times into slides I don't designate. There is no reason for this within the code below (at least not with my level of knowledge) and I've looked a lot over the web for this problem/solution to no avail..... Here is a copy of the code:

Sub SCOM_Charts()


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


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


Application.Wait (Now + TimeValue("00:00:03"))


Dim myPresentation As Object
Dim mySlide As Object
Dim PowerPointApp As Object
Dim shp As Object
Dim MySlideArray As Variant
Dim MyChartArray As Variant
Dim X As Long
Dim MySlideArray2 As Variant
Dim MyChartArray2 As Variant
Dim X2 As Long


Application.ScreenUpdating = False
Application.DisplayAlerts = 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)


MyChartArray = Array(Sheet2.ChartObjects("A-01"), Sheet2.ChartObjects("A-02"), Sheet2.ChartObjects("A-04"), Sheet2.ChartObjects("A-07"), Sheet2.ChartObjects("A-08"), Sheet1.ChartObjects("V-02"), Sheet1.ChartObjects("V-01"))


For X = LBound(MySlideArray) To UBound(MySlideArray)
MyChartArray(X).Copy
    
On Error Resume Next
    Set shp = myPresentation.Slides(MySlideArray(X)).Shapes.Paste  'Excel 2007-2010
    Set shp = PowerPointApp.ActiveWindow.Selection.ShapeRange 'Excel 2013
On Error GoTo 0
    
With myPresentation.PageSetup
    On Error Resume Next
    shp.LinkFormat.BreakLink
End With


Application.CutCopyMode = False
  
Application.Wait (Now + TimeValue("00:00:01"))


Next X


Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.CutCopyMode = False
    
ThisWorkbook.Activate
    MsgBox "Export to PowerPoint complete. Note: **All slides will be lost when this workbook is closed.**"


End Sub

I've added in wait times thinking that the program speeds were hindering performance. Didn't make a difference.
I've added in "Application.CutCopyMode = False" within the code to clear the clipboard cache. Didn't make a difference.

Anyone else run into this problem or see something in my code that is screwing things up?

Thanks a bunch. - Steve -

 

[Worf]

This is working for me:

Dim acslide As Slide
Sub SCOM_Charts()
If Not Application.CalculationState = xlDone Then DoEvents
Application.CalculateUntilAsyncQueriesDone
Application.Wait (Now + TimeValue("00:00:03"))
Dim myPresentation As Object, mySlide As Object, PowerPointApp As Object, shp As Object
Dim MySlideArray As Variant, MyChartArray As Variant, X As Long, X2 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)
MyChartArray = Array(Sheet1.ChartObjects("A-01"), Sheet1.ChartObjects("A-02"), Sheet1.ChartObjects("A-04"), _
Sheet1.ChartObjects("A-07"), Sheet1.ChartObjects("A-08"), Sheet1.ChartObjects("V-02"), Sheet1.ChartObjects("V-01"))
For X = LBound(MySlideArray) To UBound(MySlideArray)
    MyChartArray(X).Copy
    DoEvents
    Set acslide = myPresentation.Slides(MySlideArray(X))
    ns = acslide.Shapes.Count
    Set shp = acslide.Shapes.Paste
    JustDoIt ns + 1
    On Error Resume Next
    shp.LinkFormat.BreakLink
    On Error GoTo 0
    Application.CutCopyMode = False
    Application.Wait (Now + TimeValue("00:00:01"))
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%)                        ' give Office some time...
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

 

[Sphinx404]

@Worf

Thank you so much for replying... I can't tell you how long I've worked on trying to fix this...

I've implemented your solution and it keeps erroring out on

Run-time Error 1004: Application-defined or object-defined erro
Highlighting:

MyChartArray(X).Copy

it will paste the first 2 charts, then error out on slide 3

No idea why. I keep thinking it's because these charts are only tied directly into the data model, and not to any specific table or pivot table... using PP Utilities I just added the charts by selecting 'Add Pivot Chart'... but it's still a chart object, so I don't know why/if that would even matter. Especially since all the charts were created in the same exact way.

Any ideas?

 

[Sphinx404]

I've gotten it to get as far as the 3rd to last slide... but it errors out on the:

MyChartArray(X).Copy

I keep thinking that Excel is waiting to catch up or I need a pause in between each copy... Not sure if that makes sense to do, but I'm open to any suggestions.

Thanks!

 

[Worf]

Please run this test within Excel and tell me if it works or not:

Sub Only_Excel()
Dim ChartArray, i%, co As ChartObject
ChartArray = Array(Plan6.ChartObjects("A-01"), Plan6.ChartObjects("A-02"), Plan6.ChartObjects("A-04"), _
Plan6.ChartObjects("A-07"), Plan6.ChartObjects("A-08"), Plan6.ChartObjects("V-02"), Plan6.ChartObjects("V-01"))
Sheets("sheet2").Activate
For i = LBound(ChartArray) To UBound(ChartArray)
    DoEvents
    ChartArray(i).Copy
    DoEvents
    ActiveSheet.Paste                                                   ' to Sheet2
    DoEvents
    Set co = ActiveSheet.ChartObjects(ActiveSheet.ChartObjects.Count)
    co.Top = i * 30                                                     ' adjust position
    co.Left = i * 20
Next
End Sub

 

[Sphinx404]

@Worf

I'm not certain of the error you are looking for, but the code did not run from the start.

I started making changes to get the code to run by changing "Plan6" to their respective sheet names ("Sheet1,2 etc.)

When I sorted that it threw an error at

Sheets("sheet2).Activate

Once that happened, I stopped.

 

[Worf]

• Sorry for the lack of explanations. My goal is to determine if the test code will halt on the copy line. It copies the charts from one sheet to another.
• You need to change the sheet names to suit your workbook. Sheet 2 is the one where the charts are pasted.
• Do you want real charts at the Power Point presentation or chart pictures would be enough?
  

 

[Sphinx404]

Hi @Worf

So the code you sent over ran. But once again, it copied the first 2 charts and then stopped on run-time 1004 error on line:

ChartArray(i).Copy

Concerning your questions, chart pictures are all I ever wanted. I don't need any functionality, just the pictures.

Thanks again!

 

[Sphinx404]

I made a simple change based on your question:

For X = LBound(MySlideArray) To UBound(MySlideArray)
    MyChartArray(X).[B][COLOR=#ff0000]CopyPciture[/COLOR][/B]
    DoEvents
    Set acslide = myPresentation.Slides(MySlideArray(X))
    ns = acslide.Shapes.Count
    Set shp = acslide.Shapes.Paste
    JustDoIt ns + 1
    Application.CutCopyMode = False

Needless to say that I wouldn't have made this change without your suggestion. AND, it worked flawlessly. I don't really care how it works at this point, only that it does. I've spent too many hours trying to figure this out. I really appreciate the help.

Full code for those that care:

Sub SCOM_Charts()

'Object created via Insert Object>PowerPoint Presentation, etc.  Object pulled right from the sheet
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

'(2) is the starting slide
PowerPointApp.ActiveWindow.Panes(2).Activate


Set myPresentation = PowerPointApp.ActivePresentation

'slides that each chart will be copied to
MySlideArray = Array(2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16)

'the charts to be copied
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).CopyPicture
    DoEvents
    Set acslide = myPresentation.Slides(MySlideArray(X))
    ns = acslide.Shapes.Count
    Set shp = acslide.Shapes.PasteSpecial
    JustDoIt ns + 1
    Application.CutCopyMode = False
Next


Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.CutCopyMode = False
    
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