Split PPT presentation and save PDFs

Dear all,

We have a PPT presentation which includes 131 slides. On a monthly basis we have to split the presentation into several smaller team-presentations, generate a PDF and send them via email.
We already have a VBA in place in order to split the presentation. I am quite new to VBA and trying now that I can save the documents directly as PDFs.
I am trying back and forth for days now but I do not get the result I am looking for.
The perfect way would be:
- I can run one macro and automatically all team presentations are saved as PDF in the specific team folders.
What happens when I run the macro now is:
- I run the macro (1 macro per team presentation), it generates and opens a new PPT with the requested slides (e.g. 22 slides) which I can then click on Save in order that it saves it in the requested folder. Additionally, it saves a PDF of the total 131 slides in the same team folder (whereas I would be looking for the PDF only containing the 22 slides).

I am copying the VBA macro for two teams as an example, in total we have 13 teams.

Code:

---

Sub ABC()

' Variable definitions
Dim oSld As Slide
Dim oShp As Shape
Dim lTotalSlides As Long
Dim Slidenumber, SlidesNeeded, Team As String
Dim strResponse As String

' Defining the date used in nomenclature of file
myDate = Format(Date, "_yyyy_mm_dd")

'Define team name
Team = "ABC"

' Saving paths
ActivePresentation.ExportAsFixedFormat "O:\ABC" & myDate & ".pdf", ppFixedFormatTypePDF

' Finding the numbers of the required slides
Slidenumber = "" ' define an empty variable for later use
SlidesNeeded = "14,15,16,17,18,29,30,40,55,56,70,85,113,127,1 28" 'define the basic slides (dividers, etc. that are need in any presentation) -> may need adjustment from time to time

lTotalSlides = ActivePresentation.Slides.Count

For Each oSld In ActivePresentation.Slides
For Each oShp In oSld.Shapes
If oShp.HasTextFrame Then
If oShp.TextFrame.TextRange.Find(Team) Is Nothing Then
Else: Slidenumber = oSld.Slidenumber
SlidesNeeded = SlidesNeeded & "," & Slidenumber ' expands the SlidesNeeded with the slides that contain the team name in the title
End If
End If
Next
Next


' Deleting all unnecessary slides
Dim x As Long
Dim lSlideNumber As Long
Dim rayKeep() As String
Dim bKeeper As Boolean
Dim oPres As Presentation

rayKeep() = Split(SlidesNeeded, ",")

Set oPres = ActivePresentation
With oPres
For lSlideNumber = .Slides.Count To 1 Step -1
For x = LBound(rayKeep) To UBound(rayKeep)
If .Slides(lSlideNumber).SlideIndex = CLng(rayKeep(x)) Then
'.Slides(lSlideNumber).Delete
bKeeper = True
End If
Next

If Not bKeeper Then
.Slides(lSlideNumber).Delete
End If
bKeeper = False

Next
End With

End Sub

Sub CEE()

Dim oSld As Slide
Dim oShp As Shape
Dim lTotalSlides As Long
Dim Slidenumber, SlidesNeeded, Team As String
Dim strResponse As String

myDate = Format(Date, "_yyyy_mm_dd")
Team = "CEE"

ActivePresentation.ExportAsFixedFormat "O:\CEE" & myDate & ".pdf", ppFixedFormatTypePDF

Slidenumber = "" ' define an empty variable for later use
SlidesNeeded = "14,15,16,17,18,29,30,40,55,56,70,85,113,127,1 28" 'define the basic slides (dividers, etc. that are need in any presentation) -> may need adjustment from time to time

lTotalSlides = ActivePresentation.Slides.Count

For Each oSld In ActivePresentation.Slides
For Each oShp In oSld.Shapes
If oShp.HasTextFrame Then
If oShp.TextFrame.TextRange.Find(Team) Is Nothing Then
Else: Slidenumber = oSld.Slidenumber
SlidesNeeded = SlidesNeeded & "," & Slidenumber ' expands the SlidesNeeded with the slides that contain the team name in the title
End If
End If
Next
Next


' Deleting all unnecessary slides
Dim x As Long
Dim lSlideNumber As Long
Dim rayKeep() As String
Dim bKeeper As Boolean
Dim oPres As Presentation

rayKeep() = Split(SlidesNeeded, ",")

Set oPres = ActivePresentation
With oPres
For lSlideNumber = .Slides.Count To 1 Step -1
For x = LBound(rayKeep) To UBound(rayKeep)
If .Slides(lSlideNumber).SlideIndex = CLng(rayKeep(x)) Then
'.Slides(lSlideNumber).Delete
bKeeper = True
End If
Next

If Not bKeeper Then
.Slides(lSlideNumber).Delete
End If
bKeeper = False

Next
End With

End Sub

---

Any help would me much appreciated!! Already many thanks in advance!
Best, Sonja

Hi Sonj

No idea if you can adapt this, but if you have the large 131 file and create sections (right click to make Sections in the left side slide sorter column) and then this code will save each section as a separate PDF in the same folder. It's code I had, no doubt helped by John :hi:, I just changed the original .pptx to .pdf in line " .SaveAs FileName:=.path & outputFname & ".pdf" So I hope it works.

Code:

---


Option Explicit


Sub SplitFile()
    Dim original_File      As Presentation
    Dim File_Segment        As Presentation
    Dim File_name          As String
    Dim DupeName            As String
    Dim outputFname        As String
    Dim origName            As String
    Dim lIndex              As Long
    Dim K                  As Long
    Dim pathSep            As String


    pathSep = ":"
    #If Mac Then
        pathSep = ":"
    #Else
        pathSep = "/"
    #End If


    Set original_File = ActivePresentation
    DupeName = "TemporaryFile.pptx"
    DupeName = original_File.path & pathSep & DupeName
    original_File.SaveCopyAs DupeName, ppSaveAsOpenXMLPresentation
    origName = Left(original_File.Name, InStrRev(original_File.Name, ".") - 1)


    For lIndex = 1 To original_File.SectionProperties.Count
        If original_File.SectionProperties.SlidesCount(lIndex) > 0 Then
            Set File_Segment = Presentations.Open(DupeName, msoTrue, , msoFalse)
            File_name = File_Segment.SectionProperties.Name(lIndex)


            For K = original_File.SectionProperties.Count To 1 Step -1
                If File_Segment.SectionProperties.Name(K) <> File_name Then
                    Call File_Segment.SectionProperties.Delete(K, 1)
                End If
            Next K


            outputFname = pathSep & origName & "_" & original_File.SectionProperties.Name(lIndex) & "_" & Format(Date, "YYYYMMDD")


            With File_Segment
                .SaveAs FileName:=.path & outputFname & ".pdf", FileFormat:=ppSaveAsOpenXMLPresentation
                .Close
            End With
            Set File_Segment = Nothing
        End If
    Next


    Set original_File = Nothing
    Kill DupeName
    MsgBox "Split completed successfully!"


End Sub

---

Dear RayKay,
Many thanks for your reply and your help, very much appreciated!
Sorry for my late reply but I now finally had the time to check your reply and the VBA.
Unfortunately, the thing with the sections does not work :(. Some slides in the presentation are needed for each single team presentation, and I cannot add one slide to several sections.
Additionally, the team slides are not in one order..
But thank you nevertheless.

Best,
Sonja