This is my code for exporting Contents from Excel to PowerPoint. My Problem is I have only one slide in the presentation. As the criteria is met, VBA should automatically increase the slides and populate it. The slides should be of the same layout. After every IF and Else Loop I Need to add a new slide for the next Iteration. Using this code I get an error that Active X component cant create object. Any help ?
Dim oPPTShape As PowerPoint.Shape
Dim oPPTFile As PowerPoint.Presentation
Dim SlideNum As Integer
Dim pptSlide As PowerPoint.Slide
Dim pptLayout As CustomLayout
Dim strPresPath As String, strExcelFilePath As String, strNewPresPath As String
strPresPath = "C:\Users\asehgal\Desktop\OPL\Presentation1.pptx"
On Error Resume Next
Set oPPTApp = GetObject(, "PowerPoint.Application")
If oPPTApp Is Nothing Then
Set oPPTApp = CreateObject("PowerPoint.Application")
oPPTApp.Visible = True 'msoTrue
End If
On Error GoTo 0
Set oPPTFile = oPPTApp.Presentations.Open(strPresPath)
SlideNum = 1
oPPTFile.Slides(SlideNum).Select
Set oPPTShape = oPPTFile.Slides(SlideNum).Shapes("Table 1")
On Error Resume Next
If oPPTApp.Windows.Count > 0 Then
Set oPPTFile = oPPTApp.ActivePresentation
Set pptSlide = oPPTFile.Slides(oPPTApp.ActiveWindow.Selection.SlideRange.SlideIndex)
Else
Set oPPTFile = oPPTApp.Presentations.Add
Set pptSlide = oPPTFile.Slides.AddSlide(1, ppLayout)
End If
On Error GoTo 0
Do
'if topics are same
If (arrThema(p, 0) = arrThema(p + 1, 0)) Then
With oPPTShape.Table
.cell(1, 1).Shape.TextFrame.TextRange.text = arrThema(p, 0)
'if true Adda new slide here for the next iteration
End With
'If subtopics are also same
If (arrThema(p, 1) = arrThema(p + 1, 1)) Then
Else 'if subtopics are different
With oPPTShape.Table
.cell(2, 1).Shape.TextFrame.TextRange.text = arrThema(p, 1)
.cell(3, 2).Shape.TextFrame.TextRange.text = Beschreibung(p)
'if true Add a new slide here for the next iteration
End With
oPPTFile.Slides(SlideNum).Select
Set oPPTShape = oPPTFile.Slides(SlideNum).Shapes("Table 1")
With oPPTShape.Table
.cell(2, 1).Shape.TextFrame.TextRange.text = arrThema(p + 1, 1)
.cell(3, 2).Shape.TextFrame.TextRange.text = Beschreibung(p + 1)
'if true Adda new slide here for the next iteration
End With
' MsgBox "Description : " & Beschreibung(p)
End If
Else
'add a new slide here and add the details there
With oPPTShape.Table
.cell(1, 1).Shape.TextFrame.TextRange.text = arrThema(p, 0)
.cell(2, 1).Shape.TextFrame.TextRange.text = arrThema(p, 1)
.cell(3, 2).Shape.TextFrame.TextRange.text = Beschreibung(p)
'if true Adda new slide here for the next iteration
'code for adding a new slide which does not work
Set pptLayout = ActivePresentation.Slides(1).CustomLayout
Set pptSlide = ActivePresentation.Slides.AddSlide(2, pptLayout)
End With
End If
p = p + 1
Loop Until p = noThema
