How can I split a PowerPoint file with multiple slides into multiple files of 1 slide each? - vba

Question

I have a file containing 50 slides. I need to create 50 different files each containing one of the slides. I guess the quickest way includes VBA, but I don't know how to get VBA to create a new file and then get back to the master.

Answer 1

Assuming you meant "create 50 presentations", this will work. Create the destination folder before running the code:
Sub ExportSlides()
For X = 1 To ActivePresentation.Slides.Count
ActivePresentation.Slides(X).Export "c:\temp\slide" & X & ".pptx", "PPTX"
Next X
End Sub

Answer 2

I finally found out this:
Sub ExportSlides()
Dim oTempPres As Presentation
Dim X As Long
For X = 1 To ActivePresentation.Slides.Count
sFileName = "C:\Raw\Slide__" & X & ".pptx"
ActivePresentation.SaveCopyAs sFileName
Set oTempPres = Presentations.Open(sFileName, , , False)
For Y = (X + 1) To oTempPres.Slides.Count
oTempPres.Slides(X + 1).Delete
Next
For Y = 1 To X - 1
oTempPres.Slides(1).Delete
Next
oTempPres.Save
oTempPres.Close
Next X
End Sub

Answer 3

This code I had for a similar project should work to split out each PPT file to its PPT file and save it to the folder that contains the original PPT file.
Some caveats:
it struggles with embedded graphs and sometimes backgrounds.
this strips out all animations assigned to the slides or the template. If you want to keep animations or effects in, just strip out those lines of code
I haven't taken the time to smooth out automating the UserForm showing up automatically, but you can easily run it by going to the Developer tab and running the OnPresentationOpen subroutine from the macros list.
Depending on your environment's security settings, you may also need to set the .pptm containing this VBA as a Trusted Document before it will work.
Option Explicit
Sub OnPresentationOpen()
UserForm1.Show
End Sub
Public Sub ProcessPowerPoint(pptCalled)
Dim pptMainPowerPt As Presentation
Dim slideCount As Long
Dim i As Long
Dim cleanSlide As Slide
Dim newSaveName As String
Set pptMainPowerPt = Presentations.Open(pptCalled)
slideCount = ActivePresentation.Slides.Count
' Removes all animations from entire document first
For Each cleanSlide In ActivePresentation.Slides
For i = cleanSlide.TimeLine.MainSequence.Count To 1 Step -1
'Remove Each Animation
cleanSlide.TimeLine.MainSequence.Item(i).Delete
Next i
Next cleanSlide
Debug.Print "The number of slides is "; slideCount
Debug.Print "The name that is showing is "; pptCalled
Debug.Print ActivePresentation.Name
newSaveName = Left(pptCalled, InStr(pptCalled, ".") - 1)
Debug.Print "Substring name is "; newSaveName
For i = 1 To slideCount
Dim newPresentation As Presentation
Dim newName As String
Dim currentSlide As Slide
newName = newSaveName + "_Slide_" & i & ".pptx"
Set currentSlide = pptMainPowerPt.Slides.Item(i)
Set newPresentation = Application.Presentations.Add
currentSlide.Copy
newPresentation.Slides.Paste
newPresentation.SaveAs (newName)
newPresentation.Close
Next
pptMainPowerPt.Close
End Sub