when i extract from excel to PowerPoint shows automation error-CodePudding

i have code that can extract from excel to PowerPoint but sometime shows automation error

i tried using return but it doesn't work

can u plz help me with this issue?

this is my code so far: ''' Sub presntation()

Dim pptapp As PowerPoint.Application
Dim PPTPres As PowerPoint.Presentation
Dim PPTSlide As PowerPoint.Slide

'Declare Excel Variables
Dim ExcRng As Range
Dim RngArray As Variant
Dim RngArray1 As Variant
'  On Error Resume Next
' x = x - 1
' e = e - 1
' h = h - 1


Dim oPPTApp As PowerPoint.Application
Dim oPPTFile As PowerPoint.Presentation
Dim oPPTShape As PowerPoint.Shape
Dim oPPTSlide As PowerPoint.Slide

'intger ma jjsjks kskjsdkjsd

Dim Rng As Range
Dim h As Integer
Dim v As Integer

'intger1111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111

Dim m As Integer
Dim s As Integer

p = 0

On Error GoTo errhandler

'errhandler:
'Resume Next
 Dim g As Integer
Dim e As Integer
Dim p As Integer 
'Do
'DoEvents
'Loop Until ie.readstate = readystate_complete
'Tate Complete
'Get the PowerPoint Application, I am assuming it's already open.
Set pptapp = New PowerPoint.Application
    pptapp.Visible = True

Set oPPTApp = GetObject(, "PowerPoint.Application")

'Set a reference to the range you want to copy, and then copy it.
'Set Rng = Worksheets("Sheet1").Range("B3:N9")
'   Rng.Copy

'Set a reference to the active presentation.
g = 0
m = 0
Dim o As Integer
o = 0
h = 1
e = 0
x = 0
errhandler:
If p = 1 Then
oPPTFile.Slides(s).Delete

If x = 0 Then
GoTo Go
'
Else
If x = Even.Value = True Then
s = s - 1
'x = x - 1
e = e - 1
GoTo Go
Else
s = s - 1
x = x - 2
e = e - 2
GoTo Go
End If
End If
Else
End If

'Populate our array
'  If x = 0 Then
'  Sheets("WBB2").Select
'  Else
' If x = 1 Then
'  Sheets("WBB3").Select
' Else
' End If
 'End If
'Create a new instance of PowerPoint

s = 1
e = 0

' Set pptapp = New PowerPoint.Application
'    pptapp.Visible = True

'Create a new Presentation
Set PPTPres = pptapp.Presentations.Add
 'RngArray = Array(Worksheets("Backup data1").Range("E9:O38"))

RngArray = Array(Worksheets("Backup data1").Range("E9:O38"), Worksheets("Backup 
data1").Range("E6:O8"), Worksheets("Backup data1").Range("E50:O79"), Worksheets("Backup 
data1").Range("E47:O49"), Worksheets("Backup data1").Range("E87:O116"), Worksheets("Backup 
data1").Range("E84:O86"), Worksheets("Backup data1").Range("E127:O156"), Worksheets("Backup 
data1").Range("E123:O125"), Worksheets("Backup data1").Range("E165:O195"), Worksheets("Backup 
data1").Range("E163:O165"), Worksheets("Backup data1").Range("E203:O232"), Worksheets("Backup 
data1").Range("E200:O202"), Worksheets("Backup data1").Range("E241:O270"), Worksheets("Backup 
data1").Range("E237:O239"), Worksheets("Backup data1").Range("C307:L314"), Worksheets("Backup 
data1").Range("D301:K303"), Worksheets("Backup data1").Range("C335:L340"), Worksheets("Backup 
data1").Range("D329:K331"), Worksheets("Backup data1").Range("C365:L372"), Worksheets("Backup 
data1").Range("D359:K361"), _
Worksheets("Backup data1").Range("C393:L396"), Worksheets("Backup data1").Range("D387:K389"), 
Worksheets("Backup data1").Range("C421:L428"), Worksheets("Backup data1").Range("D415:K417"), 
Worksheets("Backup data1").Range("C449:L455"), Worksheets("Backup data1").Range("D443:K445"), 
Worksheets("Backup data1").Range("C477:L479"), Worksheets("Backup data1").Range("D471:K473"), 
Worksheets("Backup data1").Range("C505:L510"), Worksheets("Backup data1").Range("D499:K501"), 
Worksheets("Backup data1").Range("A531:F544"), Worksheets("Backup data1").Range("B527:K529"))
'Loop through the range array, create a slide for each range, and copy that range on to the 
slide.
For x = LBound(RngArray) To UBound(RngArray)


Go:

    'Set a reference to the range
    Set ExcRng = RngArray(x)
    
    'Copy Range
    ExcRng.Copy
    
    'Enable this line of code if you recieve error about the range not being in the clipboard 
   - This will fix that error by pausing the program for ONE Second.
    
    
    Set oPPTFile = oPPTApp.ActivePresentation
    If h = 1 Then
    If m = 2 Then
     Set oPPTSlide = Nothing
   Set PPTSlide = Nothing
    x = x - (1   g)
    Set PPTSlide = PPTPres.Slides.Add(x   1, ppLayoutBlank)
   ' Application.Wait Now   #12:00:01 AM#
    m = 1
    x = x   (1   g)
    s = s   1
    g = g   1
    Else
    m = m   1
    Set PPTSlide = PPTPres.Slides.Add(x   1, ppLayoutBlank)
    End If
    
    
    
 'Set PPTSlide = PPTPres.Slides.Add(x   1, ppLayoutBlank)
  'x = x   1

  'Set a reference to the slide you want to paste it on.
  Set oPPTSlide = oPPTFile.Slides(s)

 Else
 m = m   1
 End If

 Application.Wait Now   TimeValue("00:00:02")
 p = 1
 'On Error GoTo errhandler

 'errhandler:
 'Resume Next
  'WARNING THIS METHOD IS VERY VOLATILE, PAUSE THE APPLICATION TO SELECT THE SLIDE
  For i = 1 To 5000: DoEvents: Next
  oPPTSlide.Select

'WARNING THIS METHOD IS VERY VOLATILE, PAUSE THE APPLICATION TO PASTE THE OBJECT
  For i = 1 To 10000: DoEvents: Next
 oPPTApp.CommandBars.ExecuteMso "PasteSourceFormatting"
 oPPTApp.CommandBars.ReleaseFocus
 For i = 1 To 10000: DoEvents: Next

 '
 If e < 14 Then
 If h = 2 Then

 With oPPTApp.ActiveWindow.Selection.ShapeRange

 .Top = 20
     .Left = 25
    .Width = 910
 End With
 Set oPPTSlide = Nothing
 Set PPTSlide = Nothing
 h = 0
 'Application.Wait Now   #12:00:01 AM#
 Else
 With oPPTApp.ActiveWindow.Selection.ShapeRange
    .Top = 80
    .Left = 50
    .Height = 450
    .Width = 870
   ' Application.Wait Now   #12:00:01 AM#
  End With
  End If
  Else
   If h = 2 Then
  With oPPTApp.ActiveWindow.Selection.ShapeRange
  .Top = 20
    .Left = 25
    .Width = 910
    Set oPPTSlide = Nothing
     Set PPTSlide = Nothing
  End With
   h = 0
   Else
  With oPPTApp.ActiveWindow.Selection.ShapeRange
    .Top = 80
    .Left = 50
    .Height = 300
  '   .Height = 200
    .Width = 870
  End With

  End If
  End If


  o = o   1
  e = e   1
    'Create a new Slide
    'Set PPTSlide = PPTPres.Slides.Add(x   1, ppLayoutBlank)
   
    'Paste the range in the slide as a linked OLEObject
   'PPTApp.CommandBars.ExecuteMso
    'PPTSlide.Shapes.PasteSpecial DataType:=ppPasteOLEObject
  ' pptApplication.CommandBars.ExecuteMso ("PasteSourceFormatting")
   h = h   1
  Next x



 End Sub

CodePudding user response：

You're using 'Set oPPTFile = oPPTApp.ActivePresentation'

Depending what you do during the macro is running, PowerPoint might lose the focus, then the 'ActivePresentation' is empty. Some lines before you use 'Set PPTPres = pptapp.Presentations.Add'

As a quick workaround try 'Set oPPTFile = PPTPres' instead of 'Set oPPTFile = oPPTApp.ActivePresentation', for future projects: If you already assigned an object to a variable, use this variable instead of the ActivePresentation.

CodePudding user response：

It could be that you are not waiting long enough for the paste to be completed. Try the method described here

Option Explicit

Sub presntation()

    ' Power point variables
    Dim oPPTApp As PowerPoint.Application
    Dim oPPTPres As PowerPoint.Presentation
    Dim oPPTShape As PowerPoint.Shape
    Dim oPPTSlide As PowerPoint.Slide
   
    ' Excel Variables
    Dim xl As Excel.Application
    Dim wb As Workbook
    Dim i As Long, RngArray As Variant, p As Integer, t0 As Single
    Dim n As Integer
    t0 = Timer
    RngArray = Array("E9:O38", "E6:O8", "E50:O79", "E47:O49", _
                     "E87:O116", "E84:O86", "E127:O156", "E123:O125", _
                     "E165:O195", "E163:O165", "E203:O232", "E200:O202", _
                     "E241:O270", "E237:O239", "C307:L314", "D301:K303", _
                     "C335:L340", "D329:K331", "C365:L372", "D359:K361", _
                     "C393:L396", "D387:K389", "C421:L428", "D415:K417", _
                     "C449:L455", "D443:K445", "C477:L479", "D471:K473", _
                     "C505:L510", "D499:K501", "A531:F544", "B527:K529")
    
    ' Get the PowerPoint Application, I am assuming it's already open.
    'Set oPPTApp = GetObject(, "PowerPoint.Application")

    ' Create new presentation
    Set oPPTApp = New PowerPoint.Application
    oPPTApp.Visible = msoTrue
    Set oPPTPres = oPPTApp.Presentations.Add(msoTrue)
    
    ' create slides
    Set wb = ThisWorkbook
    Set xl = wb.Parent
    For i = LBound(RngArray) To UBound(RngArray) Step 2
   
        ' create slide
        If i Mod 2 = 0 Then
            p = p   1
            oPPTPres.Slides.Add p, ppLayoutBlank
        End If
        xl.StatusBar = "Creating slide " & p
       
        Set oPPTSlide = oPPTPres.Slides(p)
        oPPTSlide.Select
    
        'Copy Top Range
        wb.Worksheets("Backup data1").Range(RngArray(i   1)).Copy
        n = oPPTSlide.Shapes.Count
        oPPTApp.CommandBars.ExecuteMso "PasteExcelTableSourceFormatting"
        ' wait for shape to be created
        Do
            DoEvents
        Loop Until oPPTSlide.Shapes.Count > n
        
        With oPPTSlide.Shapes(oPPTSlide.Shapes.Count)
            .Top = 20
            .Left = 25
            .Width = 910
        End With
        xl.CutCopyMode = False
    
        'Copy Bottom Range
        wb.Worksheets("Backup data1").Range(RngArray(i)).Copy
        n = oPPTSlide.Shapes.Count
        oPPTApp.CommandBars.ExecuteMso "PasteExcelTableSourceFormatting"
        ' wait for shape to be created
        Do
            DoEvents
        Loop Until oPPTSlide.Shapes.Count > n
        
        With oPPTSlide.Shapes(oPPTSlide.Shapes.Count)
            .Top = 80
            .Left = 50
            .Width = 870
            If i < 14 Then
               .Height = 450
            Else
               .Height = 300
            End If
        End With
        xl.CutCopyMode = False
       
    Next i

    AppActivate xl.Caption
    xl.StatusBar = "Done"
    MsgBox p & " slides created", vbSystemModal, Format(Timer - t0, "0.0 secs")

End Sub