Search code examples
excelvbapowerpoint

Position and size with copy/paste from Excel to PowerPoint with VBA


I need to copy/paste Excel tables into PowerPoint with VBA.

I found this video: https://www.youtube.com/watch?v=dIqoXYy_Clg
The only difference is I want all my tables on the same slide.

When I run the sub, the first two tables are correctly positioned and sized but after the third, they all go into the middle of the slide and the width that I applied changes.

Is there a way to force the tables, after being pasted, to be moved and sized as originally specified.

Sub ExporttoPPT()

Dim ppt_app As New PowerPoint.Application
Dim pre As PowerPoint.Presentation
Dim sld As PowerPoint.Slide
Dim shp As PowerPoint.Shape
Dim wb As Workbook
Dim ws As Worksheet
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 vShape As Double
Dim expRng As Range

Dim Export_PPT_Sh As Worksheet
Dim ConfigRng As Range
Dim xlfile$
Dim pptfile$

Set Export_PPT_Sh = ThisWorkbook.Sheets("Export_PPT")

xlfile = Export_PPT_Sh.[excelPth]
pptfile = Export_PPT_Sh.[pptPth]

Set wb = Workbooks.Open(xlfile)
Set pre = ppt_app.Presentations.Open(pptfile)
Set ConfigRng = Export_PPT_Sh.Range("Rng_Sheets")

For Each rng In ConfigRng

    With Export_PPT_Sh
        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
        vShape = .Cells(rng.Row, 10).Value
    End With
    
    wb.Activate
    Sheets(vSheet$).Activate
    Set expRng = Sheets(vSheet$).Range(vRange$)
    expRng.Copy
    
    Set sld = pre.Slides(1)
    sld.Shapes.PasteSpecial ppPasteBitmap
    Set shp = sld.Shapes(vShape)
    
    With shp
        .Width = vWidth
        .Height = vHeight
        .Top = vTop
        .Left = vLeft
    End With
             
    Set sld = Nothing
    Set shp = Nothing
    Set expRng = Nothing
   
Next rng

Set pre = Nothing
Set ppt_app = Nothing

wb.Close False
Set wb = Nothing

End Sub

I have a range on my Excel sheet with all the properties such as width, height etc...
I'm on Excel and PowerPoint 2013.


Solution

  • Thanks to John Korchock I tried to use Placeholders instead of defining the width, heigth etc...

    That way, the tables always go as the intended place and size. The code finally looks like this :

    Sub ExporttoPPT()
    
    Dim ppt_app As New PowerPoint.Application
    Dim pre As PowerPoint.Presentation
    Dim sld As PowerPoint.Slide
    Dim shp As PowerPoint.Shape
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim rng As Range
    
    Dim vSheet$
    Dim vRange$
    Dim vPlcHolder As Long
    Dim expRng As Range
    
    Dim Export_PPT_Sh As Worksheet
    Dim ConfigRng As Range
    Dim xlfile$
    Dim pptfile$
    
    Set Export_PPT_Sh = ThisWorkbook.Sheets("Export_PPT")
    
    'Path of the PowerPoint template and the excel worbook.
    xlfile = Export_PPT_Sh.[excelPth]
    pptfile = Export_PPT_Sh.[pptPth]
    
    'Opening the excel and ppt workbooks
    Set wb = Workbooks.Open(xlfile)
    Set pre = ppt_app.Presentations.Open(pptfile)
    Set ConfigRng = Export_PPT_Sh.Range("Rng_Sheets")
    
    'Variables
    For Each rng In ConfigRng
    
        'Set Variables for tables 
        With Export_PPT_Sh
            vSheet$ = .Cells(rng.Row, 4).Value
            vRange$ = .Cells(rng.Row, 5).Value
            vPlcHolder = .Cells(rng.Row, 6).Value
        End With
    
        'Export tables to PPT
                 wb.Activate
                 Sheets(vSheet$).Activate
                 Set expRng = Sheets(vSheet$).Range(vRange$)
                 expRng.Copy
        
                 Set sld = pre.Slides(1)
    
                      With shp
                          
                         sld.Shapes.Placeholders(vPlcHolder).Select msoTrue
                         sld.Shapes.PasteSpecial ppPasteBitmap
                       
                      End With
              
            Set sld = Nothing
            Set shp = Nothing
            Set expRng = Nothing
       
    Next rng
    
    Set pre = Nothing
    Set ppt_app = Nothing
    
    wb.Close False
    Set wb = Nothing
    
    End Sub
    

    It's may be not the most optimized code, but at least it works everytime without going as the wrong place.

    Thank you again for the comments !