VBA Code - Copying and Pasting selected slides (based on selected keywords/criteria in each slide)

[erickhaw]

Hi all,

Is there any way to automate the copying and pasting of selected powerpoint slides via macro/vba? I have a master deck of 100 slides, however only selected slides are required to be paste into a new clean deck. Is there any way to copy the slides based on an array search on specific key words (e.g. Title, Content). And based on the selected phrase/title the specific slides will be extracted out and paste into a new deck. The search should based on keywords and not on slide numbers as the slides grows over time..

I will require the input from two different source to create a new deck.

e.g. DeckA (100 slides) / DeckB (20 Slides)

DeckC (New slides created based on extraction of selected slides from Deck A followed by Deck B). The new deck (output) created should be in proper slides sequence.

Thank you!
Regards
Eric

 

[Yongle]

Welcome to the forum

Yes what you want can be done - but you need to build this step by step

1. Add this code to one of your presentations to familiarise yourself with the names of the various objects (you need those help you filter what is being searched)

Sub GetShapeNames()
    Dim sld As Slide, shp As Shape, list As String, msg As String
    For Each sld In Application.ActivePresentation.Slides
        For Each shp In sld.Shapes
                msg = sld.Name & vbTab & shp.Name
                If list = "" Then list = msg Else list = list & vbCr & msg
        Next shp
    Next sld
    MsgBox list
End Sub

2. Add this code to familiarise yourself with how to search for what you want in the shapes that are relevant
- the message box lists the names of the matching slides separated by commas
- modify it to suit your search criteria
- as currently written it searches IN any shape (in every slide) where shape name begins with "Title" FOR the word or phrase entered in the input box

Sub FindText()
Dim sld As Slide, shp As Shape, list As String, myPhrase As String
myPhrase = InputBox("enter a phrase", "Search for what?", "the cat")
[CODE]For Each sld In Application.ActivePresentation.Slides
    For Each shp In sld.Shapes
        If shp.HasTextFrame Then
            If Left(shp.Name, 5) = "Title" Then
                If Not shp.TextFrame.TextRange.Find(FindWhat:=myPhrase) Is Nothing Then
                    If list = "" Then list = sld.Name Else list = list & "," & sld.Name
                End If
            End If
        End If
    Next shp
Next sld
MsgBox list
End Sub

 

[Yongle]

That last bit of code got posted a bit wrong!!

Sub FindText()
Dim sld As Slide, shp As Shape, list As String, myPhrase As String
myPhrase = InputBox("enter a phrase", "Search for what?", "the cat")

For Each sld In Application.ActivePresentation.Slides
    For Each shp In sld.Shapes
        If shp.HasTextFrame Then
            If Left(shp.Name, 5) = "Title" Then
                If Not shp.TextFrame.TextRange.Find(FindWhat:=myPhrase) Is Nothing Then
                    If list = "" Then list = sld.Name Else list = list & "," & sld.Name
                End If
            End If
        End If
    Next shp
Next sld
MsgBox list
End Sub

 

[Yongle]

After you have played around with FindText, then the procedure should be tailored to give you the search flexibility that you need without ameding the code each time

How that is achieved depends on
- which types of objects are included in your presentation (simple shapes, tables ... etc)
- and which options you want when searching (eg search Headers only , search all text, exclude headers from search, search tables, exclude tables etc)

 

[erickhaw]

Hi Yongle,

I added the following below and noted some errors. Sorry new to vba, could you assist below together with the file import from two deck.. Thank you!

Sub selct()

Dim pres1 As PowerPoint.Presentation, pres2 As PowerPoint.Presentation,
pp As Object
Set pp =GetObject(,"PowerPoint.Application")

Set pres1 = pp.ActivePresentation
Set pres2 = pp.Presentations.Add

Sub GetShapeNames()
Dim sld As Slide, shp As Shape, list As String, msg As String
For Each sld In Application.ActivePresentation.Slides
For Each shp In sld.Shapes
msg = sld.Name & vbTab & shp.Name
If list = "" Then list = msg Else list = list & vbCr & msg
Next shp
Next sld
MsgBox list
End Sub

Sub FindText()
Dim sld As Slide, shp As Shape, list As String, myPhrase As String
myPhrase = InputBox("enter a phrase", "Search for what?", "the cat")

For Each sld In Application.ActivePresentation.Slides
For Each shp In sld.Shapes
If shp.HasTextFrame Then
If Left(shp.Name, 5) = "Title" Then
If Not shp.TextFrame.TextRange.Find(FindWhat:=myPhrase) Is Nothing Then
If list = "" Then list = sld.Name Else list = list & "," & sld.Name
End If
End If
End If
Next shp
Next sld
MsgBox list
End Sub

 

[Yongle]

Start at post 2 and we'll take it from there

 

[Yongle]

This code has been tested

1. Open a NEW powerpoint presentation
2. Insert a module in that presentation and paste the code below into that module
3. Amend paths to the 2 files
4. Run the code

(As before) the search is limited to any objects with names containg Title as first 5 characters

Sub CopySlides()
    Const DeckA = "[COLOR=#ff0000]C:\Folder\SubFolder\DeckA.pptx[/COLOR]"
    Const DeckB = "[COLOR=#ff0000]C:\Folder\SubFolder\DeckB.pptx[/COLOR]"
    Dim ListOfSlides As String, myPhrase
    Dim sldNo As Variant, deck As Variant
    Dim A As Presentation, P As Presentation
    Set A = ActivePresentation
[I][COLOR=#006400]'looking for what?[/COLOR][/I]
    myPhrase = InputBox("enter a phrase", "Search for what?", "the cat")
[I][COLOR=#006400]'insert slides[/COLOR][/I]
    For Each deck In Array(DeckA, DeckB)
        Set P = Presentations.Open(deck)
        ListOfSlides = GetSlides(myPhrase, P)
        If Not ListOfSlides = "" Then
            For Each sldNo In Split(ListOfSlides, ",")
                A.Slides.InsertFromFile deck, A.Slides.Count, sldNo, sldNo
            Next sldNo
        End If
        P.Close
    Next deck
End Sub

Function GetSlides(aPhrase, aPres) As String
    Dim sld As Slide, shp As Shape, list As String
    For Each sld In aPres.Slides
        For Each shp In sld.Shapes
            If shp.HasTextFrame Then
                If Left(shp.Name, 5) = "Title" Then
                    If Not shp.TextFrame.TextRange.Find(FindWhat:=aPhrase) Is Nothing Then
                        If list = "" Then list = sld.SlideIndex Else list = list & "," & sld.SlideIndex
                    End If
                End If
            End If
        Next shp
    Next sld
    GetSlides = list
End Function

What the code does
- user provides search phrase or word
- each deck is opened in sequence
- the function returns a string containing the matching slide NUMBERS (delimited by a comma)
- that string is split and the appropriate slide inserted in the same sequence in the NEW presentation
- the deck is closed

If you would prefer to do this from Excel, that can be done, but initially it is less complicated to work in powerpoint
Amending the code to work from Excel can be done when everything is fully tested and working in powerpoint

Do you need any help amending the function to search in the manner you want?

 

[erickhaw]

This code has been tested

1. Open a NEW powerpoint presentation
2. Insert a module in that presentation and paste the code below into that module
3. Amend paths to the 2 files
4. Run the code

(As before) the search is limited to any objects with names containg Title as first 5 characters

Sub CopySlides()
    Const DeckA = "[COLOR=#ff0000]C:\Folder\SubFolder\DeckA.pptx[/COLOR]"
    Const DeckB = "[COLOR=#ff0000]C:\Folder\SubFolder\DeckB.pptx[/COLOR]"
    Dim ListOfSlides As String, myPhrase
    Dim sldNo As Variant, deck As Variant
    Dim A As Presentation, P As Presentation
    Set A = ActivePresentation
[I][COLOR=#006400]'looking for what?[/COLOR][/I]
    myPhrase = InputBox("enter a phrase", "Search for what?", "the cat")
[I][COLOR=#006400]'insert slides[/COLOR][/I]
    For Each deck In Array(DeckA, DeckB)
        Set P = Presentations.Open(deck)
        ListOfSlides = GetSlides(myPhrase, P)
        If Not ListOfSlides = "" Then
            For Each sldNo In Split(ListOfSlides, ",")
                A.Slides.InsertFromFile deck, A.Slides.Count, sldNo, sldNo
            Next sldNo
        End If
        P.Close
    Next deck
End Sub

Function GetSlides(aPhrase, aPres) As String
    Dim sld As Slide, shp As Shape, list As String
    For Each sld In aPres.Slides
        For Each shp In sld.Shapes
            If shp.HasTextFrame Then
                If Left(shp.Name, 5) = "Title" Then
                    If Not shp.TextFrame.TextRange.Find(FindWhat:=aPhrase) Is Nothing Then
                        If list = "" Then list = sld.SlideIndex Else list = list & "," & sld.SlideIndex
                    End If
                End If
            End If
        Next shp
    Next sld
    GetSlides = list
End Function

What the code does
- user provides search phrase or word
- each deck is opened in sequence
- the function returns a string containing the matching slide NUMBERS (delimited by a comma)
- that string is split and the appropriate slide inserted in the same sequence in the NEW presentation
- the deck is closed

If you would prefer to do this from Excel, that can be done, but initially it is less complicated to work in powerpoint
Amending the code to work from Excel can be done when everything is fully tested and working in powerpoint

Do you need any help amending the function to search in the manner you want?

Thanks for assisting yongle:
1. Is there any limitation to myphrase key words? As i may need to search the key words across "title" , "paragraph", "bullet points", "shapes", "charts" etc. Would such scenarios be applicable to the deck?

 

[erickhaw]

Thanks for assisting yongle:
1. Is there any limitation to myphrase key words? As i may need to search the key words across "title" , "paragraph", "bullet points", "shapes", "charts" etc. Would such scenarios be applicable to the deck?

Concurrently at the same time.

 

[Yongle]

Is there any limitation to myphrase key words? As i may need to search the key words across "title" , "paragraph", "bullet points", "shapes", "charts" etc. Would such scenarios be applicable to the deck? Concurrently at the same time.

Searching capability
- the code currently searches for a complete phrase (which may be a single word) but only in a Title box
- a list of words (or phrases) could be searched for by adding a simple loop
- other flexibility can be also be added to the search by modifying the search code

VBA needs to be told which objects to search (or not search)
- in post#2, GetShapeNames was provided to help you ascertain the names of various objects in your presentations
- GetShapeNames could be easily modified to dump the various values to a worksheet rather than a message box
- searching all objects is easy, but if you want options to "pick and choose", then the code needs modifying so that those variables can be fed in manually at the time of the search

I suggest you spend some time ..
- establishing which objects are in your presentation
- deciding what should be included or excluded in your searches
- how you want to search etc
- try running run GetShapeNames (it will probably throw up a few questions)

Here is another macro that may provide some useful information
- it provides the shape type (code) which can be looked up in the link below (the shape name should often be enough)
- values are dumped to the immediate window which can be viewed (when in VBA) with {CTRL} G

Sub ShapeTypes()
    Dim Shp As Shape, Sld As Slide
    For Each Sld In ActivePresentation.Slides
        For Each Shp In Sld.Shapes
           Debug.Print Sld.Name, Shp.Type, Shp.Name
        Next
    Next Sld
End Sub

You may be able to filter simply on names or may need to make use of object type code number - here is a list of those codes
https://docs.microsoft.com/en-us/office/vba/api/office.msoshapetype

When you are familiar with the objects in your presentation and what you want, come back with that information (including specifics based on either object names or object types)
- we can then work together to modify the code to try to achieve what you want