Avatar of Guilherme Barbosa
Guilherme Barbosa
 asked on

VBA to export Excel worksheet to PowerPoint slides

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
VBAMicrosoft PowerPointMicrosoft Excel

Avatar of undefined
Last Comment
Guilherme Barbosa

8/22/2022 - Mon
Ryan Chong

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

ASKER CERTIFIED SOLUTION
Ryan Chong

THIS SOLUTION ONLY AVAILABLE TO MEMBERS.
View this solution by signing up for a free trial.
Members can start a 7-Day free trial and enjoy unlimited access to the platform.
See Pricing Options
Start Free Trial
GET A PERSONALIZED SOLUTION
Ask your own question & get feedback from real experts
Find out why thousands trust the EE community with their toughest problems.
Guilherme Barbosa

ASKER
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
SOLUTION
Ryan Chong

THIS SOLUTION ONLY AVAILABLE TO MEMBERS.
View this solution by signing up for a free trial.
Members can start a 7-Day free trial and enjoy unlimited access to the platform.
See Pricing Options
Start Free Trial
⚡ FREE TRIAL OFFER
Try out a week of full access for free.
Find out why thousands trust the EE community with their toughest problems.
Guilherme Barbosa

ASKER
Awesome Ryan!! It is working now!! Thanks so much!!
Experts Exchange is like having an extremely knowledgeable team sitting and waiting for your call. Couldn't do my job half as well as I do without it!
James Murphy
Guilherme Barbosa

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

Cheers,
Gilly