Excel To PPT VBA Coding - excel

Question

The code runs without fault on a clear blank PowerPoint slide, but when i try Ind add multiple images from excel to PPT onto the same slide it loses its set positioning and formatting and goes to full scale on image 2,3 etc. and unable to identify the course.
Please find the code below which is used to run the script
enter code here
'app
' pre
' slide
' shapes
' text frame
' text
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 cofigRng As Range
Dim xlfile$
Dim pptfile$
Application.DisplayAlerts = False
Set adminSh = ThisWorkbook.Sheets("Admin")
Set cofigRng = adminSh.Range("Rng_sheets")
xlfile = adminSh.[excelPth]
pptfile = adminSh.[pptPth]
Application.DisplayAlerts = False
Set wb = Workbooks.Open(xlfile, False, True)
Application.DisplayAlerts = False
Set pre = ppt_app.Presentations.Open(pptfile)
For Each rng In cofigRng
'----------------- 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
' Stop
pre.Application.Activate
Set slde = pre.Slides(vSlide_No)
'Application.ActiveWindow.Panes(vSlide_No).Activate
slde.Select
slde.Shapes.PasteSpecial ppPasteBitmap 'ppPasteSecial' 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``

Answer 1

Your problem is that you use always the very first shape when you set the position properties: You write Set shp = slde.Shapes(1).
One solution is to use the last shape instead (new created shapes are put at the end of the collection):
slde.Shapes.PasteSpecial ppPasteBitmap
Set shp = slde.Shapes(slde.shapes.count)
Or you use the return value of PasteSpecial. However, the return value is a ShapeRange (a group of shapes). As in your case the group contains only one shape, you can use
Set shp = slde.Shapes.PasteSpecial(ppPasteBitmap)(1)