[英]EXCEL VBA adding a new slide to Powerpoint Automatically
This is my code for exporting Contents from Excel to PowerPoint.这是我将内容从 Excel 导出到 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.满足条件后,VBA 应自动增加幻灯片并填充它。 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.在每个 IF 和 Else 循环之后,我需要为下一次迭代添加一张新幻灯片。 Using this code I get an error that Active X component cant create object.使用此代码,我收到 Active X 组件无法创建对象的错误。 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
Use this code whever you need to insert a new slide, it will add the slide to the end of the presentation and apply your custom layout在需要插入新幻灯片时使用此代码,它会将幻灯片添加到演示文稿的末尾并应用您的自定义布局
Set pptSlide = oPPTApp.Slides.AddSlide(oPPTApp.Slides.Count + 1, pptLayout)
Edit编辑
Apologies, I couldn't test it myself.抱歉,我自己无法测试。 Try the edited code above试试上面编辑的代码
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.