VBA PPTX Fusszeile auf bestimmten Folien
13.10.2021 16:10:14
Dome
Folgende Problemstellung: Ich erzeuge aus XLSX ein PPTX auf Basis einer Vorlage und möchte u.a. die Fusszeile dynamisch setzen lassen, allerdings möchte ich, dass dabei die Folie 10 übersprungen wird.
Wie bekomme ich das in meinen Code (in die entsprechende Schlaufe) rein?
Sub create_powerpoint()
Dim pptApp As Object
Dim chtObj As Object
Dim pptSlide As Slide
Dim pptPres As Presentation
Dim strPfad As String
Dim strPOTX As String
strPfad = "URL"
strPOTX = "DATEINAME.potx"
Set pptApp = New PowerPoint.Application 'GetObject(, "Powerpoint.Application")
pptVorlage = strPfad & strPOTX
pptApp.Presentations.Open Filename:=pptVorlage, untitled:=msoTrue
Set pptPres = pptApp.ActivePresentation
For i = 2 To 13
pptPres.Slides(i).HeadersFooters.Footer.Text = "PLATZHALTER" & " | " & ThisWorkbook.Worksheets("PLATZHALTER").Range("B11").Value
pptPres.Slides(i).HeadersFooters.SlideNumber.Visible = True
pptPres.Slides(i).HeadersFooters.DateAndTime.Text = ThisWorkbook.Worksheets("PLATZHALTER").Range("B4").Value
Next i
pptPres.Slides(1).Select
pptPres.Slides(1).Shapes("TITEL").TextFrame.TextRange.Characters.Text = ThisWorkbook.Worksheets("PLATZHALTER").Range("B12").Value
pptPres.Slides(1).Shapes("UNTERTITEL").TextFrame.TextRange.Characters.Text = ThisWorkbook.Worksheets("PLATZHALTER").Range("B13").Value
pptPres.Slides(1).Shapes("NAME").TextFrame.TextRange.Characters.Text = ThisWorkbook.Worksheets("PLATZHALTER").Range("B14").Value
pptPres.Slides(1).Shapes("ORT DATUM").TextFrame.TextRange.Characters.Text = ThisWorkbook.Worksheets("PLATZHALTER").Range("B15").Value
For i = 3 To 13
pptPres.Slides(i).Shapes("TITEL").TextFrame.TextRange.Characters.Text = ThisWorkbook.Worksheets("PLATZHALTER").Range("B16").Value
Next i
HIER PASSIERT DANN WAS...
pptPres.SaveAs strPfad & ThisWorkbook.Worksheets("PLATZHALTER").Range("B9").Value & "_" & ThisWorkbook.Worksheets("PLATZHALTER").Range("B10").Value & "_" & "DATEINAME.pptx"
pptPres.Close
pptApp.Quit
Set pptPres = Nothing
Set pptApp = Nothing
End Sub
Beste Grüsse
Dome