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