Create multiple PPT from Excel using VBA

Question

I want to create multiple PPT files using VBA.

Consider this case, PPT application has been opened.
When I run the macro, it should create a new PPT file but my macro appends slides on the open file.

How to create a separate PPT file and do rest of things?

Below is part of the code.

Dim newPowerPoint As Object 'PowerPoint.Application  '
Dim activeSlide As Object 'PowerPoint.Slide
Dim sht As Worksheet 

On Error Resume Next
Set newPowerPoint = CreateObject("PowerPoint.Application")
'If newPowerPoint Is Nothing Then
    'Set newPowerPoint = New PowerPoint.Application
'End If

If newPowerPoint.Presentations.Count = 0 Then
    newPowerPoint.Presentations.Add
End If

'Show the PowerPoint
newPowerPoint.Visible = True

For Each sht In ActiveWorkbook.Sheets  
    newPowerPoint.ActivePresentation.Slides.Add newPowerPoint.ActivePresentation.Slides.Count + 1, ppLayoutText
    newPowerPoint.ActiveWindow.View.GotoSlide newPowerPoint.ActivePresentation.Slides.Count
    Set activeSlide = newPowerPoint.ActivePresentation.Slides(newPowerPoint.ActivePresentation.Slides.Count)

    activeSlide.Shapes(1).Delete
    activeSlide.Shapes(1).Delete
    Range("A1:T32").Select
    Selection.Copy
    activeSlide.Shapes.PasteSpecial(DataType:=ppPasteEnhancedMetafile).Select

RGA · Accepted Answer · 2016-07-13 11:52:13Z

1

You don't want to create a new PPT application, what you need is a new PPT Presentation, and then add slides to that. Easiest way is to add a variable for the presentation (ie Dim PPPres As Powerpoint.Presentation) and then add the new slides to that presentation

Edit: Including a version of the code that I use for initializing PPT presentations:

Dim PPApp As PowerPoint.Application
Dim PPPres As PowerPoint.Presentation
Dim PPSlide As PowerPoint.Slide

'Open PPT if not running, otherwise select active instance
On Error Resume Next
Set PPApp = GetObject(, "PowerPoint.Application")
If PPApp Is Nothing Then
    'Open PowerPoint
    Set PPApp = CreateObject("PowerPoint.Application")
    PPApp.Visible = True
End If
On Error GoTo ErrHandler

'Generate new Presentation and slide for graphic creation
Set PPPres = PPApp.Presentations.Add
Set PPSlide = PPPres.Slides.Add(1, ppLayoutBlank)
PPApp.ActiveWindow.ViewType = ppViewSlide
PPPres.PageSetup.SlideSize = ppSlideSizeOnScreen
PPApp.ActiveWindow.WindowState = ppWindowMaximized

answered Jul 13, 2016 at 11:52

RGA

2,60723 silver badges40 bronze badges

Sign up to request clarification or add additional context in comments.

1 Comment

RGA Over a year ago

You also should reset the error handler after the object (and use a get object call instead)

Nikhil Asati · Accepted Answer · 2018-12-17 11:54:34Z

*' Code to convert excel to ppt using vba

Sub ExcelToPowerPointv2() Dim rng As Range Dim PowerPointApp As Object Dim myPresentation As Object Dim mySlide As Object Dim myShape As Object Dim ArrayOne As Variant

'Create an Instance of PowerPoint
On Error Resume Next

'Is PowerPoint already opened?
Set PowerPointApp = GetObject(class:="PowerPoint.Application")

'Clear the error between errors
Err.Clear

'If PowerPoint is not already open then open PowerPoint
If PowerPointApp Is Nothing Then Set PowerPointApp = CreateObject(class:="PowerPoint.Application")

'Handle if the PowerPoint Application is not found
If Err.Number = 429 Then
MsgBox "PowerPoint could not be found, aborting."
Exit Sub
End If

On Error GoTo 0

'Optimize Code
Application.ScreenUpdating = False

Array_Sheet = Array("S1", "S2")

'Create a New Presentation
Set myPresentation = PowerPointApp.Presentations.Add
Dim pptSlide As Slide
Dim pptLayout As CustomLayout
Dim sld As Slides

'inside for loop, copy the elements of the sheet & paste it on PPT
For n = 1 To 0 Step -1 '2 sheets less 1, because of the array index 0
Set rng = ActiveWorkbook.Sheets(Array_Sheet(n)).Range("B2:B10")
rng.Copy

Set mySlide = myPresentation.Slides.Add(1, 11) '11 = ppLayoutTitleOnly
mySlide.Shapes.PasteSpecial DataType:=2  '2 = ppPasteEnhancedMetafile

Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
'Set position:
myShape.Left = 66
myShape.Top = 152
Next n

Dim PPslide As PowerPoint.Slide
'Dim sld As Slide
SlidesCount = myPresentation.Slides.Count

For SlideNumber = 1 To SlidesCount
Set rng = ActiveWorkbook.Sheets(Array_Sheet(SlideNumber - 1)).Range("D2:D10")
rng.Copy
'MsgBox (SlideNumber)
Set PPslide = myPresentation.Slides(SlideNumber)
PPslide.Shapes.PasteSpecial DataType:=2
Application.CutCopyMode = False
'mySlide(SlideNumber).Shapes.PasteSpecial DataType:=2
Set myShape = PPslide.Shapes(PPslide.Shapes.Count)
'Set position:
myShape.Left = 66
myShape.Top = 300
Next SlideNumber

Dim myTextbox As PowerPoint.Shape
For SlideNumber = 1 To SlidesCount
'MsgBox (SlideNumber)
With myPresentation.Slides(SlideNumber)
Set myTextbox = .Shapes.AddTextbox _
(Orientation:=msoTextOrientationHorizontal, Left:=500, Top:=250, Width:=400, Height:=100)
myTextbox.TextFrame.TextRange.Text = "Hello I am a text box"
End With
Next SlideNumber

End Sub

'https://stackoverflow.com/questions/41803095/paste-a-range-from-excel-into-certain-slide-of-powerpoint-template-using-vba
'Slide Count https://stackoverflow.com/questions/45391119/powerpoint-slide-count-variable-in-vba
'http://www.java2s.com/Code/VBA-Excel-Access-Word/PowerPoint/UsetheAddTextboxMethodtoaddatextboxtotheeighthslideandassigntexttoit.htm
'https://www.thespreadsheetguru.com/blog/2014/3/17/copy-paste-an-excel-range-into-powerpoint-with-vba
'https://learn.microsoft.com/en-us/office/vba/api/powerpoint.shapes.addtextbox
'https://img.chandoo.org/vba/Automatically_Create_PowerPoint_From_Excel_VBA_Code.txt*

Collectives™ on Stack Overflow

Create multiple PPT from Excel using VBA

2 Answers 2

1 Comment

Comments

Your Answer

Linked

Hot Network Questions

Collectives™ on Stack Overflow

2 Answers 2

1 Comment

Comments

Your Answer

Sign up or log in

Post as a guest

Linked

Related