How do I solve VBA error 9 - out of range? - excel

Question

I found some code on how to copy and paste a tablet from Excel to PPT, but I keep running into the error 9 'out of range'. It's my first time working with VBA, so I'm not too sure how to fix it.
Here is the code:
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 chrt As ChartObject
Dim vSheet$
Dim vRange$
Dim vChart$
Dim vWidth As Double
Dim vHeight As Double
Dim vTop As Double
Dim vLeft As Double
Dim vSlide_No As Long
Dim ShpCount As Integer
Dim expRng As Range
Dim expChart As ChartObjects
Dim adminSh As Worksheet
Dim configRng As Range
Dim configChart As Range
Dim xlfile$
Dim pptfile$
Application.DisplayAlerts = False
Set adminSh = ThisWorkbook.Sheets("Admin")
Set configRng = adminSh.Range("Rng_Sheets")
Set configChart = adminSh.Range("Chart_Sheets")
xlfile = adminSh.[excelPth]
pptfile = adminSh.[pptPth]
Set wb = Workbooks.Open(xlfile)
Set pre = ppt_app.Presentations.Open(pptfile, msoFalse)
For Each rng In configRng
With adminSh
vSheet$ = .Cells(rng.Row, 6).Value
vRange$ = .Cells(rng.Row, 7).Value
vWidth = .Cells(rng.Row, 8).Value
vHeight = .Cells(rng.Row, 9).Value
vTop = .Cells(rng.Row, 10).Value
vLeft = .Cells(rng.Row, 11).Value
vSlide_No = .Cells(rng.Row, 12).Value
End With
wb.Activate
Sheets(vSheet$).Activate
Set expRng = Sheets(vSheet$).Range(vRange$)
expRng.Copy
Set slde = pre.Slides(vSlide_No)
slde.Shapes.PasteSpecial DataType:=ppPasteOLEObject, Link:=msoTrue
ShpCount = slde.Shapes.Count
Set shp = slde.Shapes(ShpCount)
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
The VBA debugger says it is to do with the following line:
Sheets(vSheet$).Activate
Any help would be highly appreciated!!!
Thank you!
Oliver
wb.Activate
Sheets(vSheet$).Activate
Set expRng = Sheets(vSheet$).Range(vRange$)
expRng.Copy
Set slde = pre.Slides(vSlide_No)
slde.Shapes.PasteSpecial DataType:=ppPasteOLEObject, Link:=msoTrue

Answer 1

May not fix your problem but here's a refactored version combining your two loops into one. Missing any error checking such as ensuring worksheets/chartobjects etc actually exist before trying to access them.
'Declare a Type to hold the various configuration details for a copy/paste/move/size step
'All config is stored in one table with columns as indicated below
Type Settings
Type As String 'need one new column in your table for this
Sheet As String 'source worksheet
Source As String 'range address or chartobject name
Width As Double 'settings for sizing/location...
Height As Double
Top As Double
Left As Double
Slide As Long 'destination slide index
End Type
Sub ExporttoPPT()
Dim ppt_app As New PowerPoint.Application
Dim pres As PowerPoint.Presentation, ws As Worksheet
Dim config As Settings, wb As Workbook, adminSh As Workbook, configRng As Range, rw As Range
Application.DisplayAlerts = False
Set adminSh = ThisWorkbook.Sheets("Admin")
Set rw = adminSh.Range("SettingsRow1") '<< first row of settings in the config table
Set wb = Workbooks.Open(adminSh.[excelPth])
Set pres = ppt_app.Presentations.Open(adminSh.[pptPth], msoFalse)
Do While Application.CountA(rw) > 0 'loop each row in the config table while not blank
config = GetSettings(rw) 'get the configuration from this row
Set ws = wb.Sheets(config.Sheet)
With pres.Slides(config.Slide) 'destination slide
Select Case config.Type 'what kind of thing are we copying?
Case "Range"
ws.Range(config.Source).Copy
.Shapes.PasteSpecial DataType:=ppPasteOLEObject, Link:=msoTrue
Case "Chart"
ws.ChartObjects(config.Source).Copy 'or eg CopyPicture
.Shapes.PasteSpecial DataType:=ppPasteOLEObject, Link:=msoTrue
End Select
With .Shapes(.Shapes.Count) 'position and size the pasted shape
.Top = config.Top
.Left = config.Left
.Width = config.Width
.Height = config.Height
End With
End With
Set rw = rw.Offset(1, 0)
Loop
'clean up
pres.Save
pres.Close
ppt_app.Quit
wb.Close False
Application.DisplayAlerts = True
End Sub
'populate and return a `Settings` variable from a row
Function GetSettings(rw As Range) As Settings
Dim rv As Settings
rv.Type = rw.Cells(1).Value
rv.Sheet = rw.Cells(2).Value
rv.Source = rw.Cells(3).Value
rv.Width = rw.Cells(4).Value
rv.Height = rw.Cells(5).Value
rv.Top = rw.Cells(6).Value
rv.Left = rw.Cells(7).Value
rv.Slide = rw.Cells(8).Value
GetSettings = rv
End Function