Select 基于幻灯片标签的 Powerpoint 幻灯片并复制到新的演示文稿中

Question

I have a slide deck of about 30 slides which is mix of slides for different areas (Azure, AWS etc.). My goal is to be able to pull out specific slides into a new presentation based on requirement. For example pull out all slides related to Azure. So, for this i have assigned tags to each slide ( https://docs.microsoft.com/en-us/office/vba/api/powerpoint.slide.tags ). Now i need help in using these tags to pull out those slides from the main PowerPoint deck into a new PowerPoint deck.

Code to assign tags:

Sub Assign_tags()
ActivePresentation.Slides(7).Tags.Add "pname", "Azure"
ActivePresentation.Slides(8).Tags.Add "pname", "Azure"
ActivePresentation.Slides(9).Tags.Add "pname", "Azure"
ActivePresentation.Slides(10).Tags.Add "pname", "Azure"
ActivePresentation.Slides(11).Tags.Add "pname", "Azure"
ActivePresentation.Slides(12).Tags.Add "pname", "Azure"
ActivePresentation.Slides(13).Tags.Add "pname", "Azure"
ActivePresentation.Slides(14).Tags.Add "pname", "Azure"
ActivePresentation.Slides(15).Tags.Add "pname", "Azure"
ActivePresentation.Slides(16).Tags.Add "pname", "Azure"
ActivePresentation.Slides(17).Tags.Add "pname", "Azure"
ActivePresentation.Slides(18).Tags.Add "pname", "Azure"
ActivePresentation.Slides(19).Tags.Add "pname", "Azure"
ActivePresentation.Slides(20).Tags.Add "pname", "Azure"
ActivePresentation.Slides(21).Tags.Add "pname", "Azure"
ActivePresentation.Slides(22).Tags.Add "pname", "Azure"
ActivePresentation.Slides(23).Tags.Add "pname", "Azure"
ActivePresentation.Slides(24).Tags.Add "pname", "Azure"
ActivePresentation.Slides(25).Tags.Add "pname", "Azure"
ActivePresentation.Slides(26).Tags.Add "pname", "Azure"

ActivePresentation.Slides(27).Tags.Add "pname", "AWS"

ActivePresentation.Slides(28).Tags.Add "pname", "GCP"
End Sub

Code to copy the slides with Azure tag to a new presentation

    Sub SaveSeparateSlide2()

    Dim curPres As Presentation
    Set curPres = ActivePresentation
    Dim newPres As Presentation
    Set newPres = Presentations.Add

For Each s In curPres.Slides

    If s.Tags("pname") = "Azure" Then

      s.Copy
      newPres.Slides.Paste

    End If

Next

    'change your path and name here:
    newPres.SaveAs "Azure slides.pptx"
    newPres.Close

End Sub

Answer 1

I would advise using a For Loop to assign tags instead of having multiple lines of codes of the same:

For i = 7 To 26
ActivePresentation.Slides(i).Tags.Add "pname", "Azure"
Next i

Now, we need to pick out the slides which contain the Tag pname with the value azure

    Dim slNum() As Integer
    Dim n As Integer
'above are global declarations

    n = -1 'do this in some initialise sub-routine

Sub SelectSlides()
    For Each s In Application.ActivePresentation.Slides
    With s.Tags
        For i = 1 To .Count
          If .Value(i) = "Azure" Then
          n = n + 1
          ReDim Preserve slNum(n)
          slNum(n) = .Parent.SlideIndex 'We now stored the slide number of the slide which contains the tag 
          End If
        Next i
    End With
    Next
End Sub

Instead of duplicating the slide you can also copy and paste that slide in the required index.

Sub copy()
    ActivePresentation.Slides(i).Copy
    ActivePresentation.Slides.Paste Index:=5
End Sub

If you want to move the slide:

Sub move()
    ActivePresentation.Slides(3).MoveTo ToPos:=1
End Sub

Hopefully, this helps you out!

EDIT: To take the selected slides into a new presentation:

Dim pptApp As Object
Dim pptPS As Object

Set pptApp = CreateObject("Powerpoint.Application")
Set pptPS = pptApp.Presentations.Add

pptPS.SaveAs "Type folder path here"

For i = 0 To n
ActivePresentation.Slides.Item(i).Copy
pptPS.Item(1).Slides.Paste
Next i

pptPS.Save
pptPS.Close
pptApp.Quit

Set pptPS = Nothing
Set pptApp = Nothing

I haven't tested the above code, I do not think it will work as it is though (a gut feeling). Please de-bug it.

Answer 2

Option Explicit


Sub Assign_tags()
ActivePresentation.Slides(1).Tags.Add "pname", "Azure"
ActivePresentation.Slides(2).Tags.Add "pname", "AWS"
ActivePresentation.Slides(3).Tags.Add "pname", "Azure"
ActivePresentation.Slides(4).Tags.Add "pname", "GCP"
End Sub

Sub extract_slides()

Dim strTagName As String
Dim strTagValue As String

strTagName = "pname"
strTagValue = "Azure"

Dim currentPresentation As Presentation
Dim newPresentation As Presentation
Dim s As Slide

' Save reference to current presentation
Set currentPresentation = Application.ActivePresentation

' Save reference to current slide
'Set currentSlide = Application.ActiveWindow.View.Slide

' Add new Presentation and save to a reference
Set newPresentation = Application.Presentations.Add

For Each s In currentPresentation.Slides
    If s.Tags(strTagName) = "Azure" Then
         s.Copy
         ' Paste it in new Presentation
        newPresentation.Slides.Paste
    End If
Next

newPresentation.SaveAs (currentPresentation.Path & "\" & strTagValue & "_Extract.pptx")

End Sub