Copy table from Excel sheet to PowerPoint VBA Keeping location of oval shapes

Question

I'm trying to copy and paste a table from an Excel Sheet into a PowerPoint slide using VBA keeping its source formatting and keeping the location of shapes. Snapshot1 Everything seems to work fine except the oval shape placed on the table after paste was not in right location . Please help

Sub CreatePP()
    Dim ppapp As PowerPoint.Application
    Dim ppPres As PowerPoint.Presentation
    Dim ppSlide As PowerPoint.Slide
    Dim ppTextBox As PowerPoint.Shape
    Dim iLastRowReport As Integer
    Dim sh As Object
    Dim templatePath As String

        On Error Resume Next
        Set ppapp = GetObject(, "PowerPoint.Application")
        On Error GoTo 0

    'Let's create a new PowerPoint
        If ppapp Is Nothing Then
            Set ppapp = New PowerPoint.Application
        End If
    'Make a presentation in PowerPoint
        If ppapp.Presentations.Count = 0 Then
           Set ppPres = ppapp.Presentations.Add
           ppPres.ApplyTemplate "C:\Users\luunt1\AppData\Roaming\Microsoft\Templates\Document Themes\themevpb.thmx"
        End If

    'Show the PowerPoint
        ppapp.Visible = True

         For Each sh In ThisWorkbook.Sheets
         If sh.Name Like "E_KRI" Then
            ppapp.ActivePresentation.Slides.Add ppapp.ActivePresentation.Slides.Count + 1, ppLayoutBlank
            ppapp.ActiveWindow.View.GotoSlide ppapp.ActivePresentation.Slides.Count
            Set ppSlide = ppapp.ActivePresentation.Slides(ppapp.ActivePresentation.Slides.Count)
            ppSlide.Select


            iLastRowReport = Range("B" & Rows.Count).End(xlUp).Row
            Range("A1:J" & iLastRowReport).Copy
            DoEvents
            ppapp.CommandBars.ExecuteMso ("PasteExcelTableSourceFormatting")
            Wait 3
            With ppapp.ActiveWindow.Selection.ShapeRange
              .Width = 700
              .Left = 10
              .Top = 75
              .ZOrder msoSendToBack
            End With
            Selection.Font.Size = 12
          'On Error GoTo NoFileSelected
            AppActivate ("Microsoft PowerPoint")
            Set ppSlide = Nothing
            Set ppapp = Nothing
    End If
    Next   
End Sub

Private Sub Wait(ByVal nSec As Long)
    nSec = nSec + Timer
    While nSec > Timer
        DoEvents
    Wend
End Sub

Shai Rado Shai Rado · Accepted Answer · 2016-06-29T08:38:54

Try replacing your lines :

iLastRowReport = Range("B" & Rows.Count).End(xlUp).Row
Range("A1:J" & iLastRowReport).Copy
DoEvents
ppapp.CommandBars.ExecuteMso ("PasteExcelTableSourceFormatting")
Wait 3
With ppapp.ActiveWindow.Selection.ShapeRange
    .Width = 700
    .Left = 10
    .Top = 75
    .ZOrder msoSendToBack
End With

With:

iLastRowReport = Range("B" & Rows.count).End(xlUp).row
Range("A1:J" & iLastRowReport).Copy

Dim myTable                 As Object

' change according to whatever slide numbe you need
Set myTable = ppApp.ActivePresentation.Slides(1).Shapes.PasteSpecial(ppPasteMetafilePicture, msoFalse)
' Set Shape / Table properties:
myTable.Width = 700
myTable.Left = 10
myTable.Top = 75
myTable.ZOrder msoSendToBack

Copy table from Excel sheet to PowerPoint VBA Keeping location of oval shapes

1 Answers