PPT VBA实现【多文件合并】代码

守候_CJ · 发表于 2023-2-15 12:07

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

复制代码

zzpsx · 发表于 2023-2-20 19:01

非常好的代码，合并得非常流畅。
如果能跳过选择文件位置，而直接合并当前文件夹内的所有ppt，那就更好了。

守候_CJ · 发表于 2023-2-20 19:40

zzpsx 发表于 2023-2-20 19:01
非常好的代码，合并得非常流畅。
如果能跳过选择文件位置，而直接合并当前文件夹内的所有ppt，那就更好了 ...

谢谢。因为选择多文件合并通用性更强，就没用文件夹合并。

zzpsx · 发表于 2023-2-20 19:44

守候_CJ 发表于 2023-2-20 19:40
谢谢。因为选择多文件合并通用性更强，就没用文件夹合并。

可否上一个直接合并文件夹内所有ppt的代码？

守候_CJ · 发表于 2023-2-20 20:56

补充：选择文件夹，合并里面所有PPT文件（即所有后缀为.ppt*/.ppa*/.pps*的文件）

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(msoFileDialogFolderPicker)
With fdlog
If .Show Then
i = 0
Dim fso As Object
Dim extentionname
Set fso = CreateObject("Scripting.FileSystemObject")
file = Dir(CStr(.SelectedItems(1) & ""), vbNormal)
extentionname = fso.getextensionname(file)
Do While Not file = ""
If extentionname Like "pp[tas]*" Then
Set prs1 = Presentations.Open(.SelectedItems(1) & "" & CStr(file))
For Each sld In prs1.Slides
sld.Copy
prs.Slides.Paste prs.Slides.Count + 1
Next
prs1.Close
i = i + 1
End If
file = Dir
Loop
End If
End With
Set fdlog = Nothing
Set prs = Nothing
Set prs1 = Nothing
Set fso = Nothing
If i > 0 Then
MsgBox Format(i, "完成，共合并了0个文件。") & Format(Timer - t0, "用时0.000秒。")
End If
End Sub

复制代码

守候_CJ · 发表于 2023-2-20 20:59

zzpsx 发表于 2023-2-20 19:44
可否上一个直接合并文件夹内所有ppt的代码？

可以看评论补充

zzpsx · 发表于 2023-2-21 13:57

守候_CJ 发表于 2023-2-20 20:56
补充：选择文件夹，合并里面所有PPT文件（即所有后缀为.ppt*/.ppa*/.pps*的文件）

我的电脑上好像还是没有跳过选择这一步。

aman1516 · 发表于 2023-5-25 19:30

有用到，感谢分享

守候_CJ · 发表于 2023-5-26 10:18

aman1516 发表于 2023-5-25 19:30
有用到，感谢分享

nowarmy · 发表于 2023-9-14 09:45

按文件夹合并代码，补充下，大家可以直接用。
双引号中间没加斜杠，找不到文件。
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(msoFileDialogFolderPicker)
With fdlog
      If .Show Then
         i = 0
         Dim fso As Object
         Dim extentionname
         Set fso = CreateObject("Scripting.FileSystemObject")
         file = Dir(CStr(.SelectedItems(1) & "\"), vbNormal)
         Debug.Print .SelectedItems(1)
         extentionname = fso.getextensionname(file)
         Do While Not file = ""
            If extentionname Like "pp[tas]*" Then
                  Set prs1 = Presentations.Open(.SelectedItems(1) & "\" & CStr(file))
                  For Each sld In prs1.Slides
                     sld.Copy
                     prs.Slides.Paste prs.Slides.Count + 1
                  Next
                  prs1.Close
                  i = i + 1
            End If
            file = Dir
         Loop
      End If
End With
Set fdlog = Nothing
Set prs = Nothing
Set prs1 = Nothing
Set fso = Nothing
If i > 0 Then
      MsgBox Format(i, "完成，共合并了0个文件。") & Format(Timer - t0, "用时0.000秒。")
End If
End Sub

用户名		自动登录	找回密码
密码			免费注册

[分享] PPT VBA实现【多文件合并】代码

评分

评分

浏览过的版块