vba - 根据幻灯片标签选择 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

标签： vbapowerpoint

Answer 1

我建议使用 aFor 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

我还没有测试过上面的代码，但我认为它不会按原样工作（直觉）。请调试它。