Copying multiple charts from Excel and pasting in PowerPoint crashes PowerPoint application everytime

[kalyancdon]

Hi,

Every time I toggle between Excel and PowerPoint using vba, ppt crashes and I don't know the reason why. But when I try to run manually by pressing F8, it works perfectly fine as required. I have tried searching a lot of websites but didn't get a work around. My work is simple.
I have multiple charts in Excel. I need to copy some charts and paste it in ppt which is embedded in the excel file itself. Every time I run the code ppt crashes. The message says 'Microsoft PoerPoint has stopped working'
All the charts are in sheet tab named 'Charts'.
Embedded PPT is 'Object 1' in the same sheet.
In Slide 2 I need to copy charts named 'Sld2_Cht1', 'Sld2_Cht2', 'Sld2_Cht3', 'Sld2_Cht4' and paste
In Slide 3 I need to copy chart named 'Sld3_Cht1'
In Slide 4 I need to copy chart named 'Sld4_Cht1'
In Slide 5 I need to copy charts named 'Sld5_Cht1', 'Sld5_Cht2'
In Slide 6 I need to copy charts named 'Sld6_Cht1', 'Sld6_Cht2'

PPT may crash at any step of copying in any slide.
Here is the code. I don't know where I am making an error.
I have the excel file with me but did not find any option to attach the file

Any help is appreciated.

Public Sub Create_PPT()

    Dim grpItem As Shape
    Dim shp As Object
    Dim i As Long
    Dim j As Long
    Dim rList As Range
    
'Open PPT Object from Sheet Charts
    Set ppApp = CreateObject("PowerPoint.Application")
    ppApp.Visible = True


    ActiveSheet.Shapes("Object 1").Select
    Selection.Verb Verb:=3
    Set PPPres = ppApp.ActivePresentation






'SLIDE 2


PPPres.Slides(2).Select


'Annual Toner spent Mono and Color


ThisWorkbook.Sheets("Charts").Activate
ActiveSheet.Shapes.Range(Array("Sld2_Cht1")).Select
Selection.Copy
ThisWorkbook.Sheets("Charts").ChartObjects("Sld2_Cht1").Chart.ChartArea.Copy
PPPres.Slides(2).Select
ppApp.ActiveWindow.View.PasteSpecial ppPasteDefault, msoFalse
PPPres.Slides(2).Select


    ppApp.ActiveWindow.Selection.ShapeRange.LockAspectRatio = msoFalse


    ppApp.ActiveWindow.Selection.ShapeRange.Left = 20


    ppApp.ActiveWindow.Selection.ShapeRange.Top = 55


    ppApp.ActiveWindow.Selection.ShapeRange.Height = 150


    ppApp.ActiveWindow.Selection.ShapeRange.Width = 250


    Application.CutCopyMode = False




'Spend by Category


ThisWorkbook.Sheets("Charts").Activate
ActiveSheet.Shapes.Range(Array("Sld2_Cht2")).Select
ThisWorkbook.Sheets("Charts").ChartObjects("Sld2_Cht2").Chart.ChartArea.Copy
PPPres.Slides(2).Select
On Error Resume Next
ppApp.ActiveWindow.View.PasteSpecial ppPasteDefault, msoFalse
ThisWorkbook.Sheets("Charts").Activate
ActiveSheet.Shapes.Range(Array("Sld2_Cht2")).Select
ThisWorkbook.Sheets("PPT Object").ChartObjects("Sld2_Cht2").Chart.ChartArea.Copy
PPPres.Slides(2).Select


    ppApp.ActiveWindow.Selection.ShapeRange.LockAspectRatio = msoFalse


    ppApp.ActiveWindow.Selection.ShapeRange.Left = 20


    ppApp.ActiveWindow.Selection.ShapeRange.Top = 210


    ppApp.ActiveWindow.Selection.ShapeRange.Height = 150


    ppApp.ActiveWindow.Selection.ShapeRange.Width = 250


    Application.CutCopyMode = False




'Mono Toner spend by manufacture


ThisWorkbook.Sheets("Charts").Activate
ActiveSheet.Shapes.Range(Array("Sld2_Cht3")).Select
ThisWorkbook.Sheets("Charts").ChartObjects("Sld2_Cht3").Chart.ChartArea.Copy
PPPres.Slides(2).Select
ppApp.ActiveWindow.View.PasteSpecial ppPasteDefault, msoFalse
PPPres.Slides(2).Select


    ppApp.ActiveWindow.Selection.ShapeRange.LockAspectRatio = msoFalse


    ppApp.ActiveWindow.Selection.ShapeRange.Left = 350


    ppApp.ActiveWindow.Selection.ShapeRange.Top = 55


    ppApp.ActiveWindow.Selection.ShapeRange.Height = 150


    ppApp.ActiveWindow.Selection.ShapeRange.Width = 250


 Application.CutCopyMode = False




'Color Toner spend by Manufacture


ThisWorkbook.Sheets("Charts").Activate
ActiveSheet.Shapes.Range(Array("Sld2_Cht4")).Select
ThisWorkbook.Sheets("Charts").ChartObjects("Sld2_Cht4").Chart.ChartArea.Copy
PPPres.Slides(2).Select
On Error Resume Next
ppApp.ActiveWindow.View.PasteSpecial ppPasteDefault, msoFalse
ThisWorkbook.Sheets("Charts").Activate
ActiveSheet.Shapes.Range(Array("Sld2_Cht4")).Select
ThisWorkbook.Sheets("Charts").ChartObjects("Sld2_Cht4").Chart.ChartArea.Copy
PPPres.Slides(2).Select


    ppApp.ActiveWindow.Selection.ShapeRange.LockAspectRatio = msoFalse


    ppApp.ActiveWindow.Selection.ShapeRange.Left = 350


    ppApp.ActiveWindow.Selection.ShapeRange.Top = 210


    ppApp.ActiveWindow.Selection.ShapeRange.Height = 150


    ppApp.ActiveWindow.Selection.ShapeRange.Width = 250


 Application.CutCopyMode = False




'SLIDE 3


    ActiveSheet.Range("Tbl_Slide_3").Select
    ActiveCell.Offset(-2, 1).Select


If Selection.Value <> 0 Then


    ThisWorkbook.Sheets("Charts").Activate
    ActiveSheet.Shapes.Range(Array("Sld3_Cht1")).Select
    ThisWorkbook.Sheets("Charts").ChartObjects("Sld3_Cht1").Chart.ChartArea.Copy
    ppApp.Activate
    PPPres.Slides(3).Select
    ppApp.ActiveWindow.View.PasteSpecial ppPasteDefault, msoFalse


    PPPres.Slides(3).Select


        ppApp.ActiveWindow.Selection.ShapeRange.LockAspectRatio = msoFalse


        ppApp.ActiveWindow.Selection.ShapeRange.Left = 20


        ppApp.ActiveWindow.Selection.ShapeRange.Top = 75


        ppApp.ActiveWindow.Selection.ShapeRange.Height = 280


        ppApp.ActiveWindow.Selection.ShapeRange.Width = 650


        Application.CutCopyMode = False


End If






'SLIDE 4


    ActiveSheet.Range("Tbl_Slide_4").Select
    ActiveCell.Offset(-2, 1).Select


If Selection.Value <> 0 Then


    ThisWorkbook.Sheets("Charts").Activate
    ActiveSheet.Shapes.Range(Array("Sld4_Cht1")).Select
    ThisWorkbook.Sheets("Charts").ChartObjects("Sld4_Cht1").Chart.ChartArea.Copy
    ppApp.Activate
    PPPres.Slides(4).Select
    ppApp.ActiveWindow.View.PasteSpecial ppPasteDefault, msoFalse
    PPPres.Slides(4).Select


        ppApp.ActiveWindow.Selection.ShapeRange.LockAspectRatio = msoFalse


        ppApp.ActiveWindow.Selection.ShapeRange.Left = 20


        ppApp.ActiveWindow.Selection.ShapeRange.Top = 75


        ppApp.ActiveWindow.Selection.ShapeRange.Height = 280


        ppApp.ActiveWindow.Selection.ShapeRange.Width = 650


        Application.CutCopyMode = False


End If




'SLIDE 5


ThisWorkbook.Sheets("Charts").Activate
ActiveSheet.Shapes.Range(Array("Sld5_Cht1")).Select
Selection.Copy
ThisWorkbook.Sheets("Charts").ChartObjects("Sld5_Cht1").Chart.ChartArea.Copy
ppApp.Activate
    PPPres.Slides(5).Select
    ppApp.ActiveWindow.View.PasteSpecial ppPasteDefault, msoFalse


    ppApp.ActiveWindow.Selection.ShapeRange.LockAspectRatio = msoFalse


    ppApp.ActiveWindow.Selection.ShapeRange.Left = 20


    ppApp.ActiveWindow.Selection.ShapeRange.Top = 75


    ppApp.ActiveWindow.Selection.ShapeRange.Height = 250


    ppApp.ActiveWindow.Selection.ShapeRange.Width = 325


    Application.CutCopyMode = False




ThisWorkbook.Sheets("Charts").Activate
ActiveSheet.Shapes.Range(Array("Sld5_Cht2")).Select
ThisWorkbook.Sheets("Charts").ChartObjects("Sld5_Cht2").Chart.ChartArea.Copy
ppApp.Activate
    PPPres.Slides(5).Select
    ppApp.ActiveWindow.View.PasteSpecial ppPasteDefault, msoFalse


    ppApp.ActiveWindow.Selection.ShapeRange.LockAspectRatio = msoFalse


    ppApp.ActiveWindow.Selection.ShapeRange.Left = 320


    ppApp.ActiveWindow.Selection.ShapeRange.Top = 55


    ppApp.ActiveWindow.Selection.ShapeRange.Height = 280


    ppApp.ActiveWindow.Selection.ShapeRange.Width = 420


    Application.CutCopyMode = False






'SLIDE 6


ThisWorkbook.Sheets("Charts").Activate
ActiveSheet.Shapes.Range(Array("Sld6_Cht1")).Select
Selection.Copy
ThisWorkbook.Sheets("Charts").ChartObjects("Sld6_Cht1").Chart.ChartArea.Copy
ppApp.Activate
    PPPres.Slides(6).Select
    ppApp.ActiveWindow.View.PasteSpecial ppPasteDefault, msoFalse


    ppApp.ActiveWindow.Selection.ShapeRange.LockAspectRatio = msoFalse


    ppApp.ActiveWindow.Selection.ShapeRange.Left = 20


    ppApp.ActiveWindow.Selection.ShapeRange.Top = 75


    ppApp.ActiveWindow.Selection.ShapeRange.Height = 250


    ppApp.ActiveWindow.Selection.ShapeRange.Width = 325


    Application.CutCopyMode = False




ThisWorkbook.Sheets("Charts").Activate
ActiveSheet.Shapes.Range(Array("Sld6_Cht2")).Select
ThisWorkbook.Sheets("Charts").ChartObjects("Sld6_Cht2").Chart.ChartArea.Copy
ppApp.Activate
    PPPres.Slides(6).Select
    ppApp.ActiveWindow.View.PasteSpecial ppPasteDefault, msoFalse


    ppApp.ActiveWindow.Selection.ShapeRange.LockAspectRatio = msoFalse


    ppApp.ActiveWindow.Selection.ShapeRange.Left = 320


    ppApp.ActiveWindow.Selection.ShapeRange.Top = 55


    ppApp.ActiveWindow.Selection.ShapeRange.Height = 280


    ppApp.ActiveWindow.Selection.ShapeRange.Width = 420


    Application.CutCopyMode = False
    
    
    filepath = Application.ActiveWorkbook.Path & "\" & "AV Sales Presentation"
    PPPres.SaveAs filepath
    
    PPPres.Close
    ppApp.Quit
    
    ThisWorkbook.Activate
    
    MsgBox ("Presentation has been created")
    
'    frm_link.Show
    
End Sub