Add slide in Powerpoint via Excel

Hi benishiryo,

Thanks for all the help your posts have given me over the years. I didn't try your code. I modified existing code that I had.

Try the following Macro which:
a. Opens the PowerPoint file.
b. Puts Text in the first 2 TextBoxes of Existing Slides until data runs out.
c. If there are not enough slides, the last slide is duplicated as required.
d. If there are too many slides, the extras are deleted.
e. Saves and closes the PowerPoint file.

Sub PowerPointPopulateSlides()

  Const POWERPOINT_SHOWMAXIMIZED = 3
  Const POWERPOINT_SHOWNORMAL = 1
  Const POWERPOINT_SHOWMINIMIZED = 2
  
  Dim ppt As Object
  Dim pptPresentation As Object
  Dim pptSlide As Object
    
  Dim i As Long
  Dim iExistingSlideCount As Long
  Dim iLastRow As Long
  Dim iRow As Long
  Dim iShapeCount As Long
  Dim iSlideCount As Long
  
  Dim sPathAndFileName As String
  Dim sValueColumnA As String
  Dim sValueColumnB As String
  
#Const Lewis = False
#If Lewis = True Then
  sPathAndFileName = ThisWorkbook.Path & "\ExcelForumPutTextInPowerPointSlides.ppt"
#Else
  sPathAndFileName = ThisWorkbook.Path & "\PptTemplate.pptx"
#End If

  'Get the Last Row Used in Column 'A'
  iLastRow = ThisWorkbook.Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
  
  If iLastRow < 2 Then
    MsgBox "NOTHING DONE.  There is no data to put in the PowerPoint Slides."
    Exit Sub
  End If
 
 
 'Create the PowerPoint Application using Late Binding (no need for library)
  Set ppt = CreateObject("PowerPoint.Application")
  
  'Open the 'PowerPoint' file
  'Make the 'PowerPoint' file Visible
  With ppt
    .Visible = True
    Set pptPresentation = .Presentations.Open(Filename:=sPathAndFileName)
    .Visible = True
    .WindowState = POWERPOINT_SHOWMINIMIZED
  End With
  
  'Get the number of slides in the original PowerPoint File
  iExistingSlideCount = pptPresentation.Slides.Count
  
#If NEED_EXISTING_SLIDE_TEXTBOX_TEXT Then
  'Get debug output of the current contents of the existing slides
  For i = 1 To iExistingSlideCount
    iShapeCount = pptPresentation.Slides(i).Shapes.Count
  
    If iShapeCount >= 1 Then
      Debug.Print i, iShapeCount, 1, pptPresentation.Slides(i).Shapes(1).TextFrame.TextRange.Text
    End If
    If iShapeCount >= 2 Then
      Debug.Print i, iShapeCount, 1, pptPresentation.Slides(i).Shapes(2).TextFrame.TextRange.Text
    End If
  Next i
#End If
  
  
  'Initialize the Slide Count
  iSlideCount = 0
  
  For iRow = 2 To iLastRow
  
    'Increment the Slide Count
    iSlideCount = iSlideCount + 1
    
    'Create a New Slide if there are no more existing slides to populate
    If iSlideCount > iExistingSlideCount Then
      pptPresentation.Slides(pptPresentation.Slides.Count).Duplicate
    End If
  
    'Create the Slide Object
    Set pptSlide = pptPresentation.Slides(iSlideCount)
  
    'Get the Data from the Worksheet
    sValueColumnA = Trim(ThisWorkbook.Sheets("Sheet1").Cells(iRow, "A").Value)
    sValueColumnB = Trim(ThisWorkbook.Sheets("Sheet1").Cells(iRow, "B").Value)
    
    'Count the Number of Shapes on this slide
     iShapeCount = pptPresentation.Slides(iSlideCount).Shapes.Count
     iShapeCount = pptSlide.Shapes.Count
     
    'Put the Data in the Slides
    If iShapeCount >= 1 Then
      pptPresentation.Slides(iSlideCount).Shapes(1).TextFrame.TextRange.Text = sValueColumnA
      pptSlide.Shapes(1).TextFrame.TextRange.Text = sValueColumnA
    End If
    If iShapeCount >= 2 Then
      pptPresentation.Slides(iSlideCount).Shapes(1).TextFrame.TextRange.Text = sValueColumnA
      pptSlide.Shapes(2).TextFrame.TextRange.Text = sValueColumnB
    End If
    
  Next iRow
  
  'Delete Extra Slides from the back to the front
  While pptPresentation.Slides.Count > iSlideCount
    pptPresentation.Slides(pptPresentation.Slides.Count).Delete
  Wend
  
  
  'Close PowerPoint
  If Not pptPresentation Is Nothing Then
    pptPresentation.Save
    pptPresentation.Close
  End If
  
  'Quit the PowerPoint application
  If Not ppt Is Nothing Then
    ppt.Quit
  End If
  
  MsgBox "PowerPoint File has been updated."

MY_EXIT:
  'Clear the object pointers
  Set pptPresentation = Nothing
  Set ppt = Nothing
  Set pptSlide = Nothing
End Sub

Lewis

The following added Nov 25, 2015:
For anyone wanting to try this out with minimal effort, I am adding the following files in the .zip file attachment:
a. ExcelForumPutTextInPowerPointSlides.xls
b. ExcelForumPutTextInPowerPointSlides.ppt

Links to PowerPoint automation references:
http://www.globaliconnect.com/excel/...=79&Itemid=475
http://www.mahipalreddy.com/vba/ppvba.htm
http://peltiertech.com/Excel/XL_PPT.html