Excel to Powerpoint VBA for Auto Slidedecks

[Boniouk]

I have this code below which will check 2 file locations (ExcelPth and PPTPth), and pick up defined ranges (rng_#) and sheets (Rng_Sheets) from the excel file and past them into the powerpoint.

I'm getting a System Error &H80048240 (-2147188160) at random points of the macro running. The weird thing is, sometimes it completely works, the excel file closes, and the powerpoint is fully filled out. Other times it gets that error after just doing 5 or 10 of the 22 slides. What would/could cause a random timing error?

Option Explicit

Sub ExporttoPPT()

Dim ppt_app As New PowerPoint.Application
Dim pre As PowerPoint.Presentation
Dim slde As PowerPoint.Slide
Dim shp As PowerPoint.Shape
Dim wb As Workbook
Dim rng As Range

Dim vSheet$
Dim vRange$
Dim vWidth As Double
Dim vHeight As Double
Dim vTop As Double
Dim vLeft As Double
Dim vslide_No As Long
Dim expRng As Range

Dim adminSh As Worksheet
Dim configRng As Range
Dim xlfile$
Dim pptfile$

Application.DisplayAlerts = False

Set adminSh = ThisWorkbook.Sheets("Admin")
Set configRng = adminSh.Range("Rng_sheets")

xlfile = adminSh.[excelpth]
pptfile = adminSh.[pptPth]

Set wb = Workbooks.Open(xlfile)
Set pre = ppt_app.Presentations.Open(pptfile)

For Each rng In configRng

    '---- Set Variables
    
    With adminSh
        vSheet$ = .Cells(rng.Row, 4).Value
        vRange$ = .Cells(rng.Row, 5).Value
        vWidth = .Cells(rng.Row, 6).Value
        vHeight = .Cells(rng.Row, 7).Value
        vTop = .Cells(rng.Row, 8).Value
        vLeft = .Cells(rng.Row, 9).Value
        vslide_No = .Cells(rng.Row, 10).Value
    End With
    
    '---- Export to PPT
    
    wb.Activate
    Sheets(vSheet$).Activate
    Set expRng = Sheets(vSheet$).Range(vRange$)
    expRng.Copy
    
    Set slde = pre.slides(vslide_No)
    slde.Shapes.PasteSpecial ppPasteBitmap
    Set shp = slde.Shapes(1)
    
    With shp
        .Top = vTop
        .Left = vLeft
        .Width = vWidth
        .Height = vHeight
        
    End With
    
    Set shp = Nothing
    Set slde = Nothing
    Set expRng = Nothing
    
    Application.CutCopyMode = False
    Set expRng = Nothing
    
Next rng

'pre.Save
'pre.Close

Set pre = Nothing
Set ppt_app = Nothing
wb.Close False
Set wb = Nothing

Application.DisplayAlerts = True

End Sub

Thank you all

 

[Mehe]

I have this code below which will check 2 file locations (ExcelPth and PPTPth), and pick up defined ranges (rng_#) and sheets (Rng_Sheets) from the excel file and past them into the powerpoint.

I'm getting a System Error &H80048240 (-2147188160) at random points of the macro running. The weird thing is, sometimes it completely works, the excel file closes, and the powerpoint is fully filled out. Other times it gets that error after just doing 5 or 10 of the 22 slides. What would/could cause a random timing error?

Option Explicit

Sub ExporttoPPT()

Dim ppt_app As New PowerPoint.Application
Dim pre As PowerPoint.Presentation
Dim slde As PowerPoint.Slide
Dim shp As PowerPoint.Shape
Dim wb As Workbook
Dim rng As Range

Dim vSheet$
Dim vRange$
Dim vWidth As Double
Dim vHeight As Double
Dim vTop As Double
Dim vLeft As Double
Dim vslide_No As Long
Dim expRng As Range

Dim adminSh As Worksheet
Dim configRng As Range
Dim xlfile$
Dim pptfile$

Application.DisplayAlerts = False

Set adminSh = ThisWorkbook.Sheets("Admin")
Set configRng = adminSh.Range("Rng_sheets")

xlfile = adminSh.[excelpth]
pptfile = adminSh.[pptPth]

Set wb = Workbooks.Open(xlfile)
Set pre = ppt_app.Presentations.Open(pptfile)

For Each rng In configRng

    '---- Set Variables
   
    With adminSh
        vSheet$ = .Cells(rng.Row, 4).Value
        vRange$ = .Cells(rng.Row, 5).Value
        vWidth = .Cells(rng.Row, 6).Value
        vHeight = .Cells(rng.Row, 7).Value
        vTop = .Cells(rng.Row, 8).Value
        vLeft = .Cells(rng.Row, 9).Value
        vslide_No = .Cells(rng.Row, 10).Value
    End With
   
    '---- Export to PPT
   
    wb.Activate
    Sheets(vSheet$).Activate
    Set expRng = Sheets(vSheet$).Range(vRange$)
    expRng.Copy
   
    Set slde = pre.slides(vslide_No)
    slde.Shapes.PasteSpecial ppPasteBitmap
    Set shp = slde.Shapes(1)
   
    With shp
        .Top = vTop
        .Left = vLeft
        .Width = vWidth
        .Height = vHeight
       
    End With
   
    Set shp = Nothing
    Set slde = Nothing
    Set expRng = Nothing
   
    Application.CutCopyMode = False
    Set expRng = Nothing
   
Next rng

'pre.Save
'pre.Close

Set pre = Nothing
Set ppt_app = Nothing
wb.Close False
Set wb = Nothing

Application.DisplayAlerts = True

End Sub

Thank you all

Hi. Is the issue solved. I was running the same code for my automation. I'm getting error at Sheets(vSheet$).Range(vRange$) line. I'm getting Runtime error 1004. Application defined/obj defined error. Can you please assist me if you have solved it? Thanks in advance