EXCEL VBA fügt Powerpoint automatisch eine neue Folie hinzu

Question

Dies ist mein Code zum Exportieren von Inhalten von Excel nach PowerPoint. Mein Problem ist, dass ich nur eine Folie in der Präsentation habe. Wenn die Kriterien erfüllt sind, sollte VBA die Folien automatisch vergrößern und füllen. Die Folien sollten das gleiche Layout haben. Nach jeder IF und Else Schleife muss ich eine neue Folie für die nächste Iteration hinzufügen. Mit diesem Code bekomme ich einen Fehler, dass die Active X Komponente kein Objekt erzeugen kann. Irgendeine Hilfe ?

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 

Answer 1

Verwenden Sie diesen Code whever Sie eine neue Folie einfügen müssen, wird es die Folie bis zum Ende der Präsentation hinzufügen und Ihre benutzerdefinierten Layout

Set pptSlide = oPPTApp.Slides.AddSlide(oPPTApp.Slides.Count + 1, pptLayout) 

bearbeiten

Apologies gelten Ich konnte es nicht selbst testen. Versuchen Sie den bearbeiteten Code über