Individual Subs run fine, but calling them together causes the program to crash

R

Raptor776

New Member
Joined
Aug 29, 2014
Messages
46
I am writing a code to write data from Excel to Powerpoint using VBA, I am using the resources provided by theSpreadSheetGuru.com. Currently I have multiple subs that read data from each excel page and copy/paste it to Powerpoint. Running each individual sub causes the program to run fine, however when I call the subs the program crashes. I have bolded and underline the line of code in Sub Rev that causes the code to crash

So here is the Call Function: I have used a mixture of Sleep and DoEvents to keep VBA and Windows in sync, however the problem is still there:
Code: 
Sub Run_All()

Dim StartTime As Double
Dim SecondsElapsed As Double
Application.ScreenUpdating = False


StartTime = Timer
DoEvents
Call SO_AMButton
DoEvents
SecondsElapsed = Round(Timer - StartTime, 2)
Worksheets("SOS Overview").Range("AA23").Value = SecondsElapsed


Sleep (6000)
StartTime = Timer
DoEvents
Call Rev_OverBtn
SecondsElapsed = Round(Timer - StartTime, 2)
DoEvents
Worksheets("SOS Overview").Range("AA25").Value = SecondsElapsed
End Sub

This is the code is available in the SO_AMButton, I know its a bit cluttered, but largely due to various experimentations:

Code: 
Sub SO_AMButton()

'PURPOSE: Copy/Paste An Excel Range Into a New PowerPoint Presentation
'SOURCE: www.TheSpreadsheetGuru.com


Dim rng As Range
Dim graph As ChartObject
Dim i As Integer
Dim PowerPointApp As Object
Dim myPresentation As Object
Dim mySlide As Object
Dim myShape As Object


'Copy Range from Excel
Dim w As Worksheet: Set w = Sheets("SOS Overview")
Set rng = w.Range("AE4:AJ5") 'Biggest Opportunities


'Create an Instance of PowerPoint
  On Error Resume Next
    
    'Is PowerPoint already opened?
      Set PowerPointApp = GetObject(class:="PowerPoint.Application")
    
    'Clear the error between errors
      Err.Clear


    'If PowerPoint is not already open then open PowerPoint
      If PowerPointApp Is Nothing Then Set PowerPointApp = CreateObject(class:="PowerPoint.Application")
    
    'Handle if the PowerPoint Application is not found
      If Err.Number = 429 Then
        MsgBox "PowerPoint could not be found, aborting."
        Exit Sub
      End If


  On Error GoTo 0


'Optimize Code
  
  
'Create a New Presentation
  Set myPresentation = PowerPointApp.ActivePresentation


'Add a slide to the Presentation
  Set mySlide = myPresentation.Slides(3)
  mySlide.Select


'Copy Excel Range
  rng.Copy
  
'Paste to PowerPoint and position
  mySlide.Shapes.PasteSpecial ppPasteEnhancedMetafile
  Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
  Sleep (700)
  
    'Set position:
      myShape.Left = 110
      Sleep (200)
      myShape.Top = 83
      Sleep (200)
      myShape.Width = 500
      Sleep (200)
      myShape.Height = 50
      Sleep (200)


Application.CutCopyMode = False
Sleep (200)


'Copy Range from Excel
 
  Set rng = w.Range("c5:e8") 'SOS Snapshot
  DoEvents
  
  'Create an Instance of PowerPoint
  On Error Resume Next
    
    'Is PowerPoint already opened?
      Set PowerPointApp = GetObject(class:="PowerPoint.Application")
    
    'Clear the error between errors
      Err.Clear


    'If PowerPoint is not already open then open PowerPoint
      If PowerPointApp Is Nothing Then Set PowerPointApp = CreateObject(class:="PowerPoint.Application")
    
    'Handle if the PowerPoint Application is not found
      If Err.Number = 429 Then
        MsgBox "PowerPoint could not be found, aborting."
        Exit Sub
      End If


  On Error GoTo 0


'Optimize Code
  
    
'Copy Excel Range
  rng.Copy
  DoEvents


'Paste to PowerPoint and position
  mySlide.Shapes.PasteSpecial ppPasteEnhancedMetafile    '2 = ppPasteEnhancedMetafile
  Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
  Sleep (700)
  
    'Set position:
      myShape.Left = 27
      DoEvents
      myShape.Top = 134
      DoEvents
      myShape.Width = 120
      DoEvents
      myShape.Height = 130
      DoEvents


Application.CutCopyMode = False
DoEvents


'Copy Range from Excel


  Set rng = w.Range("k5:o9") 'SOS Benchmarks
  DoEvents


'Create an Instance of PowerPoint
  On Error Resume Next
    
    'Is PowerPoint already opened?
      Set PowerPointApp = GetObject(class:="PowerPoint.Application")
      DoEvents
    
    'Clear the error between errors
      Err.Clear


    'If PowerPoint is not already open then open PowerPoint
      If PowerPointApp Is Nothing Then Set PowerPointApp = CreateObject(class:="PowerPoint.Application")
    
    'Handle if the PowerPoint Application is not found
      If Err.Number = 429 Then
        MsgBox "PowerPoint could not be found, aborting."
        Exit Sub
      End If


  On Error GoTo 0


'Optimize Code
  


'Copy Excel Range
  rng.Copy
  DoEvents




'Paste to PowerPoint and position
  mySlide.Shapes.PasteSpecial ppPasteEnhancedMetafile    '2 = ppPasteEnhancedMetafile
  DoEvents
  Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
  DoEvents
  
    'Set position:
      myShape.Left = 170
      DoEvents
      myShape.Top = 134
      DoEvents
      myShape.Width = 240
      DoEvents
      myShape.Height = 130
      DoEvents


Application.CutCopyMode = False
DoEvents


 Set rng = w.Range("X12:AC16") 'SOS Quality Check
 DoEvents


'Create an Instance of PowerPoint
  On Error Resume Next
    
    'Is PowerPoint already opened?
      Set PowerPointApp = GetObject(class:="PowerPoint.Application")
    
    'Clear the error between errors
      Err.Clear


    'If PowerPoint is not already open then open PowerPoint
      If PowerPointApp Is Nothing Then Set PowerPointApp = CreateObject(class:="PowerPoint.Application")
    
    'Handle if the PowerPoint Application is not found
      If Err.Number = 429 Then
        MsgBox "PowerPoint could not be found, aborting."
        Exit Sub
      End If


  On Error GoTo 0


'Optimize Code
   




'Copy Excel Range
  rng.Copy




'Paste to PowerPoint and position
  mySlide.Shapes.PasteSpecial ppPasteEnhancedMetafile    '2 = ppPasteEnhancedMetafile
  Sleep (200)
  Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
  Sleep (200)
  
    'Set position:
      myShape.Left = 420
      Sleep (200)
      myShape.Top = 134
      Sleep (200)
      myShape.Width = 292
      Sleep (200)
      myShape.Height = 85
      Sleep (200)


Application.CutCopyMode = False
Sleep (200)


Set graph = w.ChartObjects("Weekday Morning") ' Weekday Graph
Sleep (200)


graph.Copy
Sleep (200)




mySlide.Shapes.PasteSpecial ppPasteEnhancedMetafile    '2 = ppPasteEnhancedMetafile
Sleep (700)
  Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
  Sleep (200)


      myShape.Left = 430
      Sleep (200)
      myShape.Top = 210
      Sleep (200)
      myShape.Width = 283
      Sleep (200)
      myShape.Height = 140
      Sleep (200)


Application.CutCopyMode = False
Sleep (200)


Set graph = w.ChartObjects("Hours Morning") 'Hours Graph
Sleep (200)


graph.Copy
Sleep (200)




mySlide.Shapes.PasteSpecial ppPasteEnhancedMetafile    '2 = ppPasteEnhancedMetafile
Sleep (200)
Sleep (700)
  Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
  Sleep (700)


      myShape.Left = 430
      Sleep (200)
      myShape.Top = 350
      Sleep (200)
      myShape.Width = 283
      Sleep (200)
      myShape.Height = 140
      Sleep (200)


Application.CutCopyMode = False
Sleep (200)


Set graph = w.ChartObjects("ATT Morning") 'ATT Graph
Sleep (200)


graph.Copy
Sleep (200)


Application.Wait (Now + TimeValue("0:00:01"))
Sleep (200)


mySlide.Shapes.PasteSpecial ppPasteEnhancedMetafile    '2 = ppPasteEnhancedMetafile
Sleep (700)
  Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
  Sleep (200)


Application.Wait (Now + TimeValue("0:00:01"))




      myShape.Left = 27
      Sleep (200)
      myShape.Top = 270
      Sleep (200)
      myShape.Width = 380
      Sleep (200)
      myShape.Height = 220
      Sleep (200)


Application.CutCopyMode = False
Sleep (200)


ActiveWorkbook.Worksheets("SOS Overview").Range("AA21").Value = 1
Sleep (200)


End Sub

While this is the code for the Sub Rev:

Code: 
Sub Rev_OverBtn()

'PURPOSE: Copy/Paste An Excel Range Into a New PowerPoint Presentation
'SOURCE: www.TheSpreadsheetGuru.com


Dim rng As Range
Dim graph As ChartObject
Dim i As Integer
Dim PowerPointApp As Object
Dim myPresentation As Object
Dim mySlide2 As Object
Dim myShape As Object


'Copy Range from Excel
Dim w1 As Worksheet: Set w1 = Sheets("REV Overview")
Set rng = w1.Range("AR40:AT41") 'Biggest Opportunities


'Create an Instance of PowerPoint
  On Error Resume Next
    
    'Is PowerPoint already opened?
      Set PowerPointApp = GetObject(class:="PowerPoint.Application")
    
    'Clear the error between errors
      Err.Clear


    'If PowerPoint is not already open then open PowerPoint
      If PowerPointApp Is Nothing Then Set PowerPointApp = CreateObject(class:="PowerPoint.Application")
    
    'Handle if the PowerPoint Application is not found
      If Err.Number = 429 Then
        MsgBox "PowerPoint could not be found, aborting."
        Exit Sub
      End If


  On Error GoTo 0


'Optimize Code
  
  
'Create a New Presentation
  Set myPresentation = PowerPointApp.ActivePresentation


'Add a slide to the Presentation
  Set mySlide2 = myPresentation.Slides(5)
  mySlide2.Select


'Copy Excel Range
  rng.Copy
  
  Application.Wait (Now + TimeValue("0:00:01"))
  
'Paste to PowerPoint and position
[U][B]  mySlide2.Shapes.PasteSpecial ppPasteBitmap    '2 = ppPasteEnhancedMetafile[/B][/U]
[U][B]  Set myShape = mySlide2.Shapes(mySlide2.Shapes.Count)[/B][/U]
  
  Application.Wait (Now + TimeValue("0:00:04"))
  
    'Set position:
      myShape.Left = 110
      myShape.Top = 70
      myShape.Width = 500
      myShape.Height = 50


Application.CutCopyMode = False


'Copy Range from Excel
  Set rng = w1.Range("G11:I18") 'REV Snapshot
  
  'Create an Instance of PowerPoint
  On Error Resume Next
    
    'Is PowerPoint already opened?
      Set PowerPointApp = GetObject(class:="PowerPoint.Application")
    
    'Clear the error between errors
      Err.Clear


    'If PowerPoint is not already open then open PowerPoint
      If PowerPointApp Is Nothing Then Set PowerPointApp = CreateObject(class:="PowerPoint.Application")
    
    'Handle if the PowerPoint Application is not found
      If Err.Number = 429 Then
        MsgBox "PowerPoint could not be found, aborting."
        Exit Sub
      End If


  On Error GoTo 0


'Optimize Code
  
  


  
'Copy Excel Range
  rng.Copy


Set mySlide2 = myPresentation.Slides(5)


'Paste to PowerPoint and position
  mySlide2.Shapes.PasteSpecial ppPasteBitmap    '2 = ppPasteEnhancedMetafile
  Set myShape = mySlide2.Shapes(mySlide2.Shapes.Count)
  
    'Set position:
      myShape.Left = 27
      myShape.Top = 134
      myShape.Width = 120
      myShape.Height = 130


Application.CutCopyMode = False


'Copy Range from Excel
  Set rng = w1.Range("G4:M8") 'REV Benchmarks


'Create an Instance of PowerPoint
  On Error Resume Next
    
    'Is PowerPoint already opened?
      Set PowerPointApp = GetObject(class:="PowerPoint.Application")
    
    'Clear the error between errors
      Err.Clear


    'If PowerPoint is not already open then open PowerPoint
      If PowerPointApp Is Nothing Then Set PowerPointApp = CreateObject(class:="PowerPoint.Application")
    
    'Handle if the PowerPoint Application is not found
      If Err.Number = 429 Then
        MsgBox "PowerPoint could not be found, aborting."
        Exit Sub
      End If


  On Error GoTo 0


'Optimize Code
  
Set mySlide2 = myPresentation.Slides(5)




'Copy Excel Range
  rng.Copy


For i = 1 To 1
   'milliseconds
Next i


'Paste to PowerPoint and position
  mySlide2.Shapes.PasteSpecial ppPasteBitmap    '2 = ppPasteEnhancedMetafile
  Set myShape = mySlide2.Shapes(mySlide2.Shapes.Count)
  
    'Set position:
      myShape.Left = 170
      myShape.Top = 134
      myShape.Width = 280
      myShape.Height = 130


Application.CutCopyMode = False


'Copy Range from Excel
  Worksheets("REV Overview").Activate
  Set rng = w1.Range("AG37:AJ45") 'BS List


'Create an Instance of PowerPoint
  On Error Resume Next
    
    'Is PowerPoint already opened?
      Set PowerPointApp = GetObject(class:="PowerPoint.Application")
    
    'Clear the error between errors
      Err.Clear


    'If PowerPoint is not already open then open PowerPoint
      If PowerPointApp Is Nothing Then Set PowerPointApp = CreateObject(class:="PowerPoint.Application")
    
    'Handle if the PowerPoint Application is not found
      If Err.Number = 429 Then
        MsgBox "PowerPoint could not be found, aborting."
        Exit Sub
      End If


  On Error GoTo 0


'Optimize Code
  
  
'Create a New Presentation
  Set myPresentation = PowerPointApp.ActivePresentation




'Copy Excel Range
  rng.Copy




'Paste to PowerPoint and position
  mySlide2.Shapes.PasteSpecial ppPasteBitmap    '2 = ppPasteEnhancedMetafile
  Set myShape = mySlide2.Shapes(mySlide2.Shapes.Count)
  
    'Set position:
      myShape.Left = 460
      myShape.Top = 134
      myShape.Width = 250
      myShape.Height = 129
      
   Application.CutCopyMode = False
      
'Copy Range from Excel
  Worksheets("REV Overview").Activate
  Set rng = w1.Range("AM37:AP48") 'FS List


'Create an Instance of PowerPoint
  On Error Resume Next
    
    'Is PowerPoint already opened?
      Set PowerPointApp = GetObject(class:="PowerPoint.Application")
    
    'Clear the error between errors
      Err.Clear


    'If PowerPoint is not already open then open PowerPoint
      If PowerPointApp Is Nothing Then Set PowerPointApp = CreateObject(class:="PowerPoint.Application")
    
    'Handle if the PowerPoint Application is not found
      If Err.Number = 429 Then
        MsgBox "PowerPoint could not be found, aborting."
        Exit Sub
      End If


  On Error GoTo 0


'Optimize Code
  
  




'Copy Excel Range
  rng.Copy




'Paste to PowerPoint and position
  mySlide2.Shapes.PasteSpecial ppPasteBitmap    '2 = ppPasteEnhancedMetafile
  Set myShape = mySlide2.Shapes(mySlide2.Shapes.Count)
  
    'Set position:
      myShape.Left = 460
      myShape.Top = 270
      myShape.Width = 250
      myShape.Height = 214


Application.CutCopyMode = False


Set graph = w1.ChartObjects("BS") ' BS Graph


graph.Copy




mySlide2.Shapes.PasteSpecial ppPasteBitmap    '2 = ppPasteEnhancedMetafile
  Set myShape = mySlide2.Shapes(mySlide2.Shapes.Count)


      myShape.Left = 27
      myShape.Top = 270
      myShape.Width = 200
      myShape.Height = 214


Application.CutCopyMode = False


Set graph = w1.ChartObjects("FS") 'FS Graph


graph.Copy




mySlide2.Shapes.PasteSpecial ppPasteBitmap    '2 = ppPasteEnhancedMetafile
  Set myShape = mySlide2.Shapes(mySlide2.Shapes.Count)


      myShape.Left = 250
      myShape.Top = 270
      myShape.Width = 200
      myShape.Height = 214
      
Application.CutCopyMode = False


End Sub
 

Excel Facts

When did Power Query debut in Excel?
Although it was an add-in in Excel 2010 & Excel 2013, Power Query became a part of Excel in 2016, in Data, Get & Transform Data.
You must log in or register to reply here.

Similar threads

S
  • Question
VBA code for Excel tables into ppt - automation
Replies
3
Views
2K
Trebor76
T
C
  • Question
Replacing PowerPoint Input using Find and Replace Arrays from Excel through VBA
Replies
0
Views
1K
ckcs
C
A
  • Solved
Excel to PowerPoint error ( Object variable or with block not set )
Replies
2
Views
1K
Akbarov
A
A
  • Question
.CopyPicture and paste with 2 ranges
Replies
0
Views
593
Akbarov
A
E
  • Solved
Need to Export Excel sheet range to Multiple Powerpoint Slides
2
Replies
13
Views
3K
sijpie
sijpie

Forum statistics

Threads
1,214,853
Messages
6,121,935
Members
449,056
Latest member
denissimo

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