EXCEL VBA自動向Powerpoint添加新幻燈片

Question

這是我將內容從 Excel 導出到 PowerPoint 的代碼。 我的問題是演示文稿中只有一張幻燈片。 滿足條件后，VBA 應自動增加幻燈片並填充它。 幻燈片應具有相同的布局。 在每個 IF 和 Else 循環之后，我需要為下一次迭代添加一張新幻燈片。 使用此代碼，我收到 Active X 組件無法創建對象的錯誤。 有什么幫助嗎？

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

在需要插入新幻燈片時使用此代碼，它會將幻燈片添加到演示文稿的末尾並應用您的自定義布局

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

編輯

抱歉，我自己無法測試。 試試上面編輯的代碼