VBA to export Excel worksheet to PowerPoint slides

Guilherme Barbosa
Guilherme Barbosa used Ask the Experts™
on
VBA to Export Excel sheet to PowerPoint:

Hi experts,

I am using the following VBA to export my worksheet to PowerPoint presentation, however if I change the slicer in my Pivot Chart and export again the worksheet, the code is creating a new presentation, rather than a new slide.

I would like to add the new selection into the same presentation, just adding as a new slide.

I believe I need a loop indexing and counting the slides.

Any suggestions, please.


VBA Code:

Sub ExceltoPowerPoint()

Dim PowerPointApp As Object
Dim myPresentation As Object
Dim wb As Workbook
Dim ws As Worksheet
Dim namecheck As Range

Set PowerPointApp = GetPowerPointApp()
Set myPresentation = PowerPointApp.Presentations.Add

Call ExportResourcePlanSlide(myPresentation, ThisWorkbook.ActiveSheet.Range("a2:m40"))

PowerPointApp.Visible = True
PowerPointApp.Activate

Application.CutCopyMode = False

End Sub



Function GetPowerPointApp() As Object

On Error Resume Next
Set PowerPointApp = GetObject(class:="PowerPoint.Application")
Err.Clear
If PowerPointApp Is Nothing Then Set PowerPointApp = CreateObject(class:="PowerPoint.Application")
If Err.Number = 429 Then
MsgBox "PowerPoint could not be found, aborting."
Exit Function
End If
Set GetPowerPointApp = PowerPointApp
On Error GoTo 0

End Function


Sub ExportResourcePlanSlide(ByVal myPresentation As Object, ByRef rng As Range)

'Create new slide------------------------------------------------------------------------------------------------------

Set myslide = myPresentation.Slides.Add(myPresentation.Slides.Count + 1, 12) '11 = ppLayoutTitleOnly

'Copy range and paste to powerpoint------------------------------------------------------------------------------------

rng.Copy
myslide.Shapes.PasteSpecial DataType:=2 '2 = ppPasteEnhancedMetafile

'Add Commentary Text Box-----------------------------------------------------------------------------------------------

Set myTextBox = myslide.Shapes.AddTextbox(1, Left:=100, Top:=100, Width:=8.19 * 28.3465, Height:=350)

With myTextBox
.TextFrame.TextRange.Text = ""
.TextFrame.TextRange.Font.Size = 10
.Left = 24.9 * 28.3465
.Top = 3.18 * 28.3465
End With

End Sub
Comment
Watch Question

Do more with

Expert Office
EXPERT OFFICE® is a registered trademark of EXPERTS EXCHANGE®
Ryan ChongSoftware Team Lead

Commented:
you may try this:

If PowerPointApp.Presentations.Count > 0 Then
    Set myPresentation = PowerPointApp.Presentations(1) 'Default to first opened powerpoint
Else
    Set myPresentation = PowerPointApp.Presentations.Add
End If

Open in new window

Software Team Lead
Commented:
similarly, you could also output to most recent opened powerpoint by doing this:

Set myPresentation = PowerPointApp.Presentations(PowerPointApp.Presentations.Count)

Open in new window

Author

Commented:
Hi Ryan,

Thank you for your suggestion, but it didn't worked, can you please tell me in which part of the code I should include your code?

That is the way I did:

***************************************

Sub ExceltoPowerPoint()

Dim PowerPointApp As Object
Dim myPresentation As Object
Dim wb As Workbook
Dim ws As Worksheet
Dim namecheck As Range

Set PowerPointApp = GetPowerPointApp()
Set myPresentation = PowerPointApp.Presentations.Add
 
  Call ExportResourcePlanSlide(myPresentation, ThisWorkbook.ActiveSheet.Range("a2:m40"))

  PowerPointApp.Visible = True
  PowerPointApp.Activate

  Application.CutCopyMode = False
 
End Sub



Function GetPowerPointApp() As Object

  On Error Resume Next
      Set PowerPointApp = GetObject(class:="PowerPoint.Application")
      Err.Clear
      If PowerPointApp Is Nothing Then Set PowerPointApp = CreateObject(class:="PowerPoint.Application")
      If Err.Number = 429 Then
        MsgBox "PowerPoint could not be found, aborting."
        Exit Function
      End If
      Set GetPowerPointApp = PowerPointApp
  On Error GoTo 0
 
End Function


Sub ExportResourcePlanSlide(ByVal myPresentation As Object, ByRef rng As Range)

    Set myPresentation = PowerPointApp.Presentations(PowerPointApp.Presentations.Count)

'Create new slide------------------------------------------------------------------------------------------------------
   
    Set mySlide = myPresentation.Slides.Add(myPresentation.Slides.Count + 1, 12) '11 = ppLayoutTitleOnly
 
'Copy range and paste to powerpoint------------------------------------------------------------------------------------
 
  rng.Copy
  mySlide.Shapes.PasteSpecial DataType:=2  '2 = ppPasteEnhancedMetafile
 
'Add Commentary Text Box-----------------------------------------------------------------------------------------------

  Set myTextBox = mySlide.Shapes.AddTextbox(1, Left:=100, Top:=100, Width:=8.19 * 28.3465, Height:=350)
 
  With myTextBox
    .TextFrame.TextRange.Text = ""
    .TextFrame.TextRange.Font.Size = 10
    .Left = 24.9 * 28.3465
    .Top = 3.18 * 28.3465
  End With

End Sub
Exploring SQL Server 2016: Fundamentals

Learn the fundamentals of Microsoft SQL Server, a relational database management system that stores and retrieves data when requested by other software applications.

Ryan ChongSoftware Team Lead
Commented:
try amend your sub: ExceltoPowerPoint() to:

Sub ExceltoPowerPoint()

Dim PowerPointApp As Object
Dim myPresentation As Object
Dim wb As Workbook
Dim ws As Worksheet
Dim namecheck As Range

Set PowerPointApp = GetPowerPointApp()

If PowerPointApp.Presentations.Count > 0 Then
    Set myPresentation = PowerPointApp.Presentations(PowerPointApp.Presentations.Count)
Else
    Set myPresentation = PowerPointApp.Presentations.Add
End If
  
  Call ExportResourcePlanSlide(myPresentation, ThisWorkbook.ActiveSheet.Range("a2:m40"))

  PowerPointApp.Visible = True
  PowerPointApp.Activate

  Application.CutCopyMode = False
  
End Sub

Open in new window


it tested working for me.

Author

Commented:
Awesome Ryan!! It is working now!! Thanks so much!!

Author

Commented:
Thank you Ryan for your prompt feedback and help!! Really appreciate it!

Cheers,
Gilly

Do more with

Expert Office
Submit tech questions to Ask the Experts™ at any time to receive solutions, advice, and new ideas from leading industry professionals.

Start 7-Day Free Trial