PPT VBA：多文件合并

Sub 合并PPT()

    Dim t0 As Single: t0 = Timer

    Dim fdlog As FileDialog

    Dim prs As Presentation

    Dim prs1 As Presentation

    Dim sld As Slide

    Dim file

    Dim i As Integer

    

    Set prs = Presentations.Add

    Set fdlog = Application.FileDialog(msoFileDialogFilePicker)

    With fdlog

        .AllowMultiSelect = True

        With .Filters

            .Clear

            .Add "PPT文件", "*.ppt*;*.ppa*;*.pps*", 1

            .Add "所有文件", "*.*", 2

        End With

        If .Show Then

            i = 0

            For Each file In .SelectedItems

                Set prs1 = Presentations.Open(CStr(file))

                For Each sld In prs1.Slides

                    sld.Copy

                    prs.Slides.Paste prs.Slides.Count + 1

                Next

                prs1.Close

                i = i + 1

            Next

        End If

    End With

    

    Set fdlog = Nothing

    Set prs = Nothing

    Set prs1 = Nothing

    If i > 0 Then

        MsgBox Format(i, "完成，共合并了0个文件。") & Format(Timer - t0, "用时0.000秒。")

    End If

End Sub