I have this code working to paste every three paragraphs from Word into a PPT presentation. What I would like is to have a slide one used as the template for all the other slides. Slide one is formatted as the master template. Right now I get the paragraphs pasting, but it doesn't use the master slide layout of Title and Content.
Sub SelectEveryThreeParagraphs()
Dim i As Long
Dim x As Long
x = ActiveDocument.Paragraphs.Count
For i = 1 To x Step 3
ActiveDocument.Paragraphs(i).Range.Select
Selection.MoveDown Unit:=wdParagraph, Count:=2, Extend:=wdExtend
Selection.Copy
'--------------------------------------------------------------------------------------
'Create PPT
Dim PPPres As Object
Dim PPApp As Object
Dim PPSlide As Object
Dim SlideCount As Long
Dim strFile As String: strFile = "Report.pptm"
On Error Resume Next
Set PPApp = GetObject(Class:="PowerPoint.Application")
If PPApp Is Nothing Then
Set PPApp = CreateObject(Class:="PowerPoint.Application")
Else
Set PPPres = PPApp.Presentations(strFile)
End If
On Error GoTo 0
If PPPres Is Nothing Then
Set PPPres = PPApp.Presentations.Open(ActiveDocument.Path & Application.PathSeparator & strFile)
Else
'Exit Sub ' If you want quit the macro if the workbook is already open, do it here
End If
PPApp.ActiveWindow.ViewType = 1
SlideCount = PPPres.Slides.Count
Set PPSlide = PPPres.Slides.Add(SlideCount + 1, 2)
PPApp.ActiveWindow.View.GotoSlide PPSlide.SlideIndex
With PPSlide
.Shapes(1).TextFrame.TextRange = "Title of Slide"
.Shapes(2).TextFrame.TextRange = Selection
' .Shapes.Paste.Select
' With .Shapes(.Shapes.Count)
' .LockAspectRatio = msoFalse
' .Left = 0
' .Top = 90
' .Height = 400
' End With
End With
'--------------------------------------------------------------------------------------
Next i
End Sub
Sub SelectEveryThreeParagraphs()
Dim i As Long
Dim x As Long
'Create PPT
Dim PPApp As PowerPoint.Application ' Object
Dim PPPres As PowerPoint.Presentation ' Object
Dim PPSlide As PowerPoint.Slide ' Object
Dim PPTLayout As PowerPoint.CustomLayout ' Object
Dim SlideCount As Long
Dim strFile As String
strFile = "Report.pptm"
On Error Resume Next
Set PPApp = GetObject(Class:="PowerPoint.Application")
If PPApp Is Nothing Then
Set PPApp = CreateObject(Class:="PowerPoint.Application")
Else
Set PPPres = PPApp.Presentations(strFile)
End If
On Error GoTo 0
Set PPPres = PPApp.Presentations.Open(ActiveDocument.Path & Application.PathSeparator & strFile)
Set PPTLayout = PPPres.Slides(1).CustomLayout
PPApp.ActiveWindow.ViewType = 1
x = ActiveDocument.Paragraphs.Count
For i = 1 To x Step 3
ActiveDocument.Paragraphs(i).Range.Select
Selection.MoveDown Unit:=wdParagraph, Count:=2, Extend:=wdExtend
' Add slide
SlideCount = PPPres.Slides.Count
Set PPSlide = PPPres.Slides.AddSlide(SlideCount + 1, PPTLayout)
PPApp.ActiveWindow.View.GotoSlide PPSlide.SlideIndex
With PPSlide
.Shapes(1).TextFrame.TextRange = "Title of Slide"
.Shapes(2).TextFrame.TextRange = Selection
End With
Next i
End Sub
By the way, I changed the declarations of PPApp etc. for testing purposes. You can change them back to Object if you don't want to set a reference to the Microsoft PowerPoint n.0 Object Library.
x = Range("I1").Value
For i = 1 To x Step 3
'Copy Range from Excel
Set Rng = ThisWorkbook.ActiveSheet.Cells(i, 1).Resize(3)
Rng.Copy
SlideCount = PPPres.Slides.Count
Set PPSlide = PPPres.Slides.AddSlide(SlideCount + 1, PPTLayout)
PPApp.ActiveWindow.View.GotoSlide PPSlide.SlideIndex
With PPSlide
.Shapes(1).TextFrame.TextRange = Range("H1").Value
.Shapes(2).TextFrame.TextRange.PasteSpecial DataType:=2
End With
Next i