How can I separate each slides from one PPT file?

[Deniz]

Hi Everyone.
I have a powerpoint file(Power point 2016) which has 100 page(slides). What I want is to automatically separate each slide to create 100 seperate powerpoint files with keeping the existing masterslide features, design and layout. I actually achieved this operation with a macro. However it is changing all layout and master slide features. Is there any way to do that easily in a way I desire to do ?


Thank you very much in advance

[John Wilson]

When you crosspost on other forums its ALWAYS good to mention this.
https://answers.microsoft.com/en-us/msoffice/forum/msoffice_powerpoint-mso_winother-mso_2016/how-can-i-separate-each-slides-from-one-power/2bfe4f41-fd7b-4983-9f1c-c0a40721339f

See if this works:


Sub splitFiles()
Dim tempR As Presentation
Dim opres As Presentation
Dim L As Long
Dim oFolder As String
'requires v. 2010 or later
On Error Resume Next
Set opres = ActivePresentation
Set tempR = Presentations.Add
oFolder = Environ("USERPROFILE") & "\Desktop\Files\"
MkDir oFolder
For L = 1 To opres.Slides.Count
opres.Slides(L).Copy
tempR.Windows(1).Panes(1).Activate
Call CommandBars.ExecuteMso("PasteSourceFormatting")
Call tempR.SaveCopyAs(oFolder & "Slide" & CStr(L) & ".pptx", ppSaveAsOpenXMLPresentation)
tempR.Slides(1).Delete
Next L
tempR.Saved = True
tempR.Close
End Sub

[Deniz]

When you crosspost on other forums its ALWAYS good to mention this.
https://answers.microsoft.com/en-us/msoffice/forum/msoffice_powerpoint-mso_winother-mso_2016/how-can-i-separate-each-slides-from-one-power/2bfe4f41-fd7b-4983-9f1c-c0a40721339f

See if this works:


Sub splitFiles()
Dim tempR As Presentation
Dim opres As Presentation
Dim L As Long
Dim oFolder As String
'requires v. 2010 or later
On Error Resume Next
Set opres = ActivePresentation
Set tempR = Presentations.Add
oFolder = Environ("USERPROFILE") & "\Desktop\Files\"
MkDir oFolder
For L = 1 To opres.Slides.Count
opres.Slides(L).Copy
tempR.Windows(1).Panes(1).Activate
Call CommandBars.ExecuteMso("PasteSourceFormatting")
Call tempR.SaveCopyAs(oFolder & "Slide" & CStr(L) & ".pptx", ppSaveAsOpenXMLPresentation)
tempR.Slides(1).Delete
Next L
tempR.Saved = True
tempR.Close
End Sub


Hello John Wilson, Thanks a lot for your answer.
Your code generates better results but still not in a way I want. Because The original slide size is 4:3 but when I seperate that with your code, it is becoming 9:16 and affecting all other text and titles changing their location. I want the slides stay in same size when we seperated them with macro. How can we do that?

[John Wilson]

Good to mention your original was 4:3. Also if this works can I ask that you go back to the other forums where you asked because otherwise folk may be working away on it whan you already have an answer.


Sub splitFiles()
Dim tempR As Presentation
Dim opres As Presentation
Dim L As Long
Dim oFolder As String
'requires v. 2010 or later
On Error Resume Next
Set opres = ActivePresentation
Set tempR = Presentations.Add
tempR.PageSetup.SlideSize = opres.PageSetup.SlideSize
oFolder = Environ("USERPROFILE") & "\Desktop\Files\"
MkDir oFolder
For L = 1 To opres.Slides.Count
opres.Slides(L).Copy
tempR.Windows(1).Panes(1).Activate
Call CommandBars.ExecuteMso("PasteSourceFormatting")
Call tempR.SaveCopyAs(oFolder & "Slide" & CStr(L) & ".pptx", ppSaveAsOpenXMLPresentation)
tempR.Slides(1).Delete
Next L
tempR.Saved = True
tempR.Close
End Sub

[Deniz]

Good to mention your original was 4:3. Also if this works can I ask that you go back to the other forums where you asked because otherwise folk may be working away on it whan you already have an answer.


Sub splitFiles()
Dim tempR As Presentation
Dim opres As Presentation
Dim L As Long
Dim oFolder As String
'requires v. 2010 or later
On Error Resume Next
Set opres = ActivePresentation
Set tempR = Presentations.Add
tempR.PageSetup.SlideSize = opres.PageSetup.SlideSize
oFolder = Environ("USERPROFILE") & "\Desktop\Files\"
MkDir oFolder
For L = 1 To opres.Slides.Count
opres.Slides(L).Copy
tempR.Windows(1).Panes(1).Activate
Call CommandBars.ExecuteMso("PasteSourceFormatting")
Call tempR.SaveCopyAs(oFolder & "Slide" & CStr(L) & ".pptx", ppSaveAsOpenXMLPresentation)
tempR.Slides(1).Delete
Next L
tempR.Saved = True
tempR.Close
End Sub

John Wilson. Thanks a lot. Now it is working completely right. I will copy the answer for my other questions in other forums and will informed them it is the answer.