Select 基於幻燈片標簽的 Powerpoint 幻燈片並復制到新的演示文稿中

Question

我有一個包含大約 30 張幻燈片的幻燈片，其中混合了不同領域（Azure、AWS 等）的幻燈片。 我的目標是能夠根據要求將特定幻燈片提取到新的演示文稿中。 例如，拉出與 Azure 相關的所有幻燈片。 因此，為此我為每張幻燈片分配了標簽（ https://docs.microsoft.com/en-us/office/vba/api/powerpoint.slide.tags ）。 現在我需要幫助來使用這些標簽將這些幻燈片從主 PowerPoint 幻燈片中拉出到新的 PowerPoint 幻燈片中。

分配標簽的代碼：

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

將帶有 Azure 標記的幻燈片復制到新演示文稿的代碼

    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

我建議使用For Loop來分配標簽，而不是使用多行相同的代碼：

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

現在，我們需要選擇包含標簽pname且值為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

除了復制幻燈片，您還可以復制該幻燈片並將其粘貼到所需的索引中。

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

如果要移動幻燈片：

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

希望這可以幫助您！

編輯：要將選定的幻燈片放入新的演示文稿中：

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

我還沒有測試過上面的代碼，但我認為它不會按原樣工作（直覺）。 請調試它。

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