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/...c-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/...c-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.