In this post I will show you how to automate PowerPoint from excel using vba. Let’s learn this using following example.
This is a simple database which contains data of several companies. Database contains data like vision, history, branches etc. of each company. So in this example we will create PowerPoint file for each company.
First, let’s learn how to start PowerPoint application from Excel.
Sub StartPowerPoint()
Dim oPPTApp As PowerPoint.Application
Set oPPTApp = CreateObject("PowerPoint.Application")
oPPTApp.Visible = msoTrue
End Sub
|
So if you run above macro it will launch PowerPoint application.
For this example we use PowerPoint template file which is saved at the folder where our database file is. I created this very simple PowerPoint template to show you how to automate various tasks from excel.
First we need to develop the program to loop through each row and create separate PowerPoint file for each company. So following is the starting part of our program.
Sub GeneratePowerPointFiles()
Dim WS As Worksheet
Dim i As Long
Dim PptFileName As String
Dim oPPTApp As PowerPoint.Application
Dim oPPTFile As PowerPoint.Presentation
Dim oPPTShape As PowerPoint.Shape
Dim oPPTSlide As PowerPoint.Slide
Set oPPTApp = CreateObject("PowerPoint.Application")
oPPTApp.Visible = msoTrue
Set WS = ActiveSheet
'find last row of WS
WS_LastRow = WS.Cells.Find("*", [A1], , , xlByRows, xlPrevious).Row
For i = 2 To WS_LastRow
Next i
End Sub
|
Then within each loop, we need to open the template and do the editing. So we can open the PowerPoint template file for each loop like this.
For i = 2 To WS_LastRow
If WS.Range("G" & i).Value <> "" Then
DestinationPPT = ThisWorkbook.Path & "\" & "Company Template.pptx"
Set oPPTFile = oPPTApp.Presentations.Open(FileName:=DestinationPPT)
End If
Next i
|
Now let’s look at our first slide.
Here we need to put name of each company while loop through the rows. So we should replace “Company Name” with values in column A. To do that first we need to identify the names of objects inside the PowerPoint presentation. This post explains how to find names of objects in a PowerPoint presentation.
How to Find Names of Objects in a PowerPoint Slide
So if the name of the title object is “Title 1” then we can do it as follows.
oPPTFile.Slides(1).Shapes("Title 1").TextFrame.TextRange.Text = WS.Range("A" & i).Value
|
Now let’s move to our next slide.
We have a textbox in this slide. And the name of the textbox is “TextBox 4”. Here we need to put vision of each company.
oPPTFile.Slides(2).Shapes("TextBox 4").TextFrame.TextRange.Text = "Our Vision" & vbCrLf & vbCrLf & WS.Range("B" & i).Value
|
vbCrLf used to add space between title and the vision. And we have another different type of object in our next slide.
We have rectangle here and we need to put history of each company inside this rectangle. As the name of the rectangle is “Rectangle 3” we can automate it as follows.
oPPTFile.Slides(3).Shapes("Rectangle 3").TextFrame.TextRange.Text = WS.Range("C" & i).Value
|
Note that you need to put slide number before the object name. Because two different slides can have objects with same name. This is our next slide.
We have two types of objects in this slide. We need to put branch names in “Content Placeholder 2” object. We can do it like this.
oPPTFile.Slides(4).Shapes("Content Placeholder 2").TextFrame.TextRange.Text = WS.Range("D" & i).Value & vbCrLf & WS.Range("E" & i).Value & vbCrLf & WS.Range("F" & i).Value
|
Next we need to save the PowerPoint presentation with the name given in the column G.
PptFileName = WS.Range("G" & i).Value & ".pptx"
PptFileNameString = oPPTFile.Path & "\" & PptFileName
oPPTFile.SaveAs PptFileNameString
|
Also we need to close the original PowerPoint Template at the end of each loop.
'Close PowerPoint
oPPTFile.Close
Set oPPTFile = Nothing
DoEvents
|
So below is the full code of this VBA program.
Sub GeneratePowerPointFiles()
Dim WS As Worksheet
Dim i As Long
Dim PptFileName As String
Dim WebsiteAddress As String
Dim oPPTApp As PowerPoint.Application
Dim oPPTFile As PowerPoint.Presentation
Dim oPPTShape As PowerPoint.Shape
Dim oPPTSlide As PowerPoint.Slide
Set oPPTApp = CreateObject("PowerPoint.Application")
oPPTApp.Visible = msoTrue
Set WS = ActiveSheet
'find last row of WS
WS_LastRow = WS.Cells.Find("*", [A1], , , xlByRows, xlPrevious).Row
For i = 2 To WS_LastRow
If WS.Range("G" & i).Value <> "" Then
DestinationPPT = ThisWorkbook.Path & "\" & "Company Template.pptx"
Set oPPTFile = oPPTApp.Presentations.Open(FileName:=DestinationPPT)
Application.Wait (Now + TimeValue("0:00:02"))
DoEvents
oPPTFile.Slides(1).Shapes("Title 1").TextFrame.TextRange.Text = WS.Range("A" & i).Value
oPPTFile.Slides(2).Shapes("TextBox 4").TextFrame.TextRange.Text = "Our Vision" & vbCrLf & vbCrLf & WS.Range("B" & i).Value
oPPTFile.Slides(3).Shapes("Rectangle 3").TextFrame.TextRange.Text = WS.Range("C" & i).Value
oPPTFile.Slides(4).Shapes("Content Placeholder 2").TextFrame.TextRange.Text = WS.Range("D" & i).Value & vbCrLf & _
WS.Range("E" & i).Value & vbCrLf & WS.Range("F" & i).Value
PptFileName = WS.Range("G" & i).Value & ".pptx"
PptFileNameString = oPPTFile.Path & "\" & PptFileName
oPPTFile.SaveAs PptFileNameString
'Close PowerPoint
oPPTFile.Close
Set oPPTFile = Nothing
DoEvents
End If
Next i
oPPTApp.Quit
MsgBox "Completed!", vbInformation, ""
End Sub
|
So the result files will be created in the folder where our original PowerPoint template file is.