text 如何从保存在多个文件中的幻灯片快速编译单个PowerPoint演示文稿？

Posted 2021-05-02

Option Explicit
Sub Update_Slide_Data()

Dim Ppres As Presentation
Set Ppres = Presentations("C:\Users\Angelina\Documents\2015_Review.pptm")

Dim location As String
location = "C:\Users\Angelina\Documents\2013_Review.pptx"

Dim PPS As PowerPoint.Slide
Dim Sh As Shape

Dim Str As String
Dim i As Integer
Dim StrNo As Long
Dim ResNo As Long
Dim indicator As String

Dim Data As PowerPoint.Presentation
'***************************************************************************************************************************
indicator = InputBox("Please enter the desired indicator in UPPER case")

For i = 1 To Ppres.Slides.Count
    Str = Ppres.Slides(i).Shapes.Title.TextFrame.TextRange
    StrNo = InStr(Str, indicator)

Select Case indicator
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Case "FLASH"
If StrNo <> 0 Then
    Set Data = Presentations.Open("C:\Users\angelina\Documents\Pics.pptm")
    
    Data.Slides.Range(Array(34, 37)).Copy
    Ppres.Slides.Paste (i + 1)
    Ppres.Save
    
    Data.Close
    Call Irrelevant
End If

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Case "PROJECTS"
If StrNo <> 0 Then
    Set Data = Presentations.Open("C:\Users\angelina\Documents\Projects.pptm")
    
    Data.Slides.Range(Array(2, 3)).Copy
    Ppres.Slides.Paste (i + 1)
    Ppres.Save
    
    Data.Close
End If

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Case "IMPORT"
If StrNo <> 0 Then
    Set Data = Presentations.Open("C:\Users\angelina\Documents\Balance.pptm")
    
    Data.Slides.Range(Array(1, 2, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 16, 17, 18, 19, 22, 23, 25, 26, 27, 28)).Copy
    Ppres.Slides.Paste (i + 1)
    Ppres.Save
    
    Data.Close
End If

End Select
Next i

'save as pptx
If Ppres.Slides.Count >= 69 Then Call S

End Sub