make new pptx files based on the value of a textbox
Hello,
I am hopeful someone out there can lend me a quick hand.
I have a some pptx file that all have a subanner textbox value. all the slide format is all the same. I am using excel to open the files.
I'm working to spilt the larger presentation into smaller presentations based on the value of the subanner textbox.
also i need to keep the original slide formatting in the spilt presentations.
sometimes it runs fine, other times I get an error that says " Something went wrong that might make PowerPoint Unstable"
any words of wisdom would be greatly appreciated
Code:
Sub CopySlides()
Dim pptApp As PowerPoint.Application
Dim pptPres As PowerPoint.Presentation
Dim newPres As PowerPoint.Presentation
Dim slide As PowerPoint.slide
Dim subbanner As PowerPoint.shape
Dim lastSubbannerText As String
Dim filePath As String
'Open the PowerPoint presentation
Set pptApp = CreateObject("PowerPoint.Application")
filePath = Range("a12").Value
Set pptPres = pptApp.Presentations.Open(filePath)
'Create a new presentation
Set newPres = pptApp.Presentations.Add
'Loop through each slide in the presentation
For Each slide In pptPres.Slides
'Find the subbanner shape on the slide
Set subbanner = slide.Shapes.Range(Array("subbanner")).Item(1)
'If the subbanner text on the current slide is different from the last slide, save and close the current presentation and create a new one
If subbanner.TextFrame.TextRange.Text <> lastSubbannerText Then
'Save and close the current presentation
'newPres.Close
'Create a new presentation
Set newPres = pptApp.Presentations.Add
End If
'Copy the slide to the clipboard
slide.Copy
'Paste the slide into the new presentation with the source formatting
pptApp.CommandBars.ExecuteMso ("PasteSourceFormatting")
'Save the text of the current subbanner for comparison with the next slide
lastSubbannerText = subbanner.TextFrame.TextRange.Text
Next
'Save and close the final presentation
'newPres.Close
End Sub
