将幻灯片从多个ppt文件复制到单个ppt文件

Question

Sub Combine_ppt()

Dim parent As PowerPoint.Application
Dim child As PowerPoint.Application
Dim pname, cname As String

pname = "C:\PPT\ParentFile.ppt"
On Error Resume Next
Set parent = CreateObject("PowerPoint.Application")
parent.Presentations.Open pname
On Error GoTo 0
If parent Is Nothing Then
    MsgBox "Parent File not Found"
    Exit Sub
End If
parent.Visible = True
fld = "C:\PPT\"
cname = Dir(fld & "*Child*.ppt")
Do While cname <> ""
    Set child = CreateObject("PowerPoint.Application")
    child.Presentations.Open "C:\PPT\" & cname
    ccount = child.ActivePresentation.Slides.Count
    For i = 1 To ccount
        child.ActivePresentation.Slides(i).copy
        parent.ActivePresentation.Slides.Paste
    Next i
    child.Quit
    Set child = Nothing
Loop
End Sub

我正在尝试将幻灯片从所有文件名中包含“孩子”一词的ppt复制到父ppt。当我运行代码时，我看到复制的幻灯片被粘贴到相同的演示文稿中，而不是父幻灯片，并且代码进入无限循环，一次又一次地打开相同的子文件，并且不移动文件夹中的另一个子文件。敬请指教。

Answer 1

您没有循环遍历Dir中的所有文件，因为您错过了为每个文件调用Dir

你只需要在循环的末尾添加一句话

cname = Dir(fld & "*Child*.ppt")
Do While cname <> ""
   ...
   cname=Dir()
Loop

Answer 2

我修改如下所示

Sub Combine_ppt()

    Dim parent As PowerPoint.Application
    Dim child As PowerPoint.Application
    Dim pname, cname As String

    pfname = "123.pptx"
    pname = "D:\temp\PPT\" & pfname
    On Error Resume Next
    Set parent = CreateObject("PowerPoint.Application")
    parent.Presentations.Open pname
    On Error GoTo 0
    If parent Is Nothing Then
        MsgBox "Parent File not Found"
    Exit Sub
    End If
    parent.Visible = True
    fld = "D:\temp\PPT\"
    cname = Dir(fld & "*child*.pptx")
    Do While cname <> ""
        Set child = CreateObject("PowerPoint.Application")
        child.Presentations.Open "D:\temp\PPT\" & cname
        ccount = child.ActivePresentation.Slides.Count

        For i = 1 To ccount
            'child.ActivePresentation.Slides(i).Copy
            Presentations(child.ActivePresentation.Name).Slides(i).Copy
            'Presentations("ParentFile.pptx").Slides.Paste
            Presentations(pfname).Slides.Paste

        Next i

        'child.Quit
        Presentations(child.ActivePresentation.Name).Close
        Set child = Nothing
        cname = Dir()
    Loop

End Sub