Home » excel » Copy Excel table to PowerPoint via VBA and save

Copy Excel table to PowerPoint via VBA and save

Posted by: admin April 23, 2020 Leave a comment


I am trying to mass-generate a series of PowerPoint presentations. My slide would contain two elements, both created and copied from Excel. I am using Office 2010.

The first element is a SmartArt graphic which is smoothly done. The second one is a few cells that I would like to copy as a Table object (instead of a linked image). After wasting a few hours with “Shapes”, I found this, but I cannot manipulate its height and width after pasting.

PPApp.CommandBars.ExecuteMso ("PasteSourceFormatting")

Then, when I tried to save the presentation using the following, I realised only the SmartArt is saved; the pasted table is not saved even though the saveAs command occured after the paste.

PPApp.CommandBars.ExecuteMso ("PasteSourceFormatting")
PPPres.SaveAs saveName, ppSaveAsDefault

More bizarrely, I found that when I added a msgbox command for debugging above between paste and save, the table is saved correctly. However, I am trying to mass produce these files and cannot sit down to close each message box.

My questions:
1. How can I change the table’s height/width/alignment after pasting?
2. How can I save my file with the table in it?

EDITED, my current code

Sub copyAllToPpt()

Dim PPApp As PowerPoint.Application
Dim PPPres As PowerPoint.Presentation
Dim PPSlide As PowerPoint.Slide
Dim PPName, xlName As String

xlName = ActiveWorkbook.Name
Dim saveName As String

Dim y As Integer
y = ActiveCell.Row
saveName = ActiveSheet.Cells(y, "B").Value & "-" & ActiveSheet.Cells(y, "A").Value & " Stats"

Set PPApp = CreateObject("Powerpoint.Application")
PPApp.Visible = True
Set PPPres = PPApp.Presentations.Add
PPName = PPPres.Name

PPApp.ActiveWindow.ViewType = ppViewSlide

Set PPSlide = PPPres.Slides.Add(1, ppLayoutBlank)



PPApp.ActiveWindow.Selection.ShapeRange.Height = 288
PPApp.ActiveWindow.Selection.ShapeRange.Width = 641
PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, msoTrue
PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, msoTrue
'Macro is working as expected up to here


'Table is copied in subroutine


PPApp.CommandBars.ExecuteMso ("PasteSourceFormatting")
'Application.Wait (Now + TimeValue("0:00:05"))
'Tried the Wait() to no avail.

DoEvents: DoEvents: DoEvents

PPApp.ActivePresentation.SaveAs saveName, ppSaveAsDefault

End Sub
How to&Answers:

This works when I run it from within PPT; you’ll need to adapt it by adding references to the PPT application object, etc:

Dim oSh As Object
Dim oSl As Object
Dim x As Long

x = 1 ' or whatever slide you want to work with

Set oSl = ActivePresentation.Slides(x)

CommandBars.ExecuteMso ("PasteSourceFormatting")
DoEvents: DoEvents: DoEvents

Set oSh = oSl.Shapes(oSl.Shapes.Count)

oSh.Left = 0
' etc

Without the DoEvents statements, it fails, in exactly the same way as your save problem fails. Unless you give PPT a few cycles to deal with the newly pasted shape, it thinks that it’s not there.