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

K

kalyancdon

New Member
Joined
Jul 14, 2011
Messages
4
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.

Code: 
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
 

Excel Facts

Copy formula down without changing references
If you have =SUM(F2:F49) in F50; type Alt+' in F51 to copy =SUM(F2:F49) to F51, leaving the formula in edit mode. Change SUM to COUNT.
You must log in or register to reply here.

Similar threads

A
  • Question
Export multiple Ranges/Charts to PowerPoint
Replies
1
Views
750
abc_xyz
A
A
  • Question
Paste Excel Charts to PPT Dynamically using chart name
Replies
1
Views
480
Domenic
D
C
  • Question
Replacing PowerPoint Input using Find and Replace Arrays from Excel through VBA
Replies
0
Views
1K
ckcs
C
M
  • Question
Unable to run Copy and Paste Excel range to Powerpoint VBA in O365
Replies
0
Views
1K
msnovice
M
L
  • Question
Copy & Pasting multiple Excel Ranges to Seperate Powerpoint Slides with VBA
Replies
7
Views
6K
Domenic
D

Forum statistics

Threads
1,214,864
Messages
6,121,986
Members
449,058
Latest member
oculus

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top