设为首页收藏本站

简字体切换切换到宽版

ExcelHome技术论坛»论坛 › Excel 技术交流与问答 › Excel VBA程序开发 › 求助上千份ppt如何批量删除最后一页？和excel宏通用吗？

EH技术汇-专业的职场技能充电站	妙哉！函数段子手趣味讲函数	Excel服务器-会Excel,做管理系统	Excel Home精品图文教程库
HR薪酬管理数字化实战	Excel 2021函数公式学习大典	Excel数据透视表实战秘技	打造核心竞争力的职场宝典
300集Office 2010微视频教程	数据工作者的案头书	免费直播课集锦	ExcelHome出品 - VBA代码宝免费下载
	用ChatGPT与VBA一键搞定Excel	WPS表格从入门到精通	Excel VBA经典代码实践指南

发新帖

查看: 1252|回复: 4

[求助] 求助上千份ppt如何批量删除最后一页？和excel宏通用吗？

修炼中的鱼

TA的精华主题

TA的得分主题

发表于 2020-2-7 13:36 | 显示全部楼层 |阅读模式

[广告] ★用Excel做企业管理系统，Excel服务器学习和下载★

部编版六年级下11 十六年前的回忆（二）.zip (412.81 KB, 下载次数: 22)

求助, ppt, 如何, 批量, 删除

回复

约定的童话

TA的精华主题

TA的得分主题

发表于 2020-2-7 16:57 | 显示全部楼层

[广告] ★ ChatOffice，能听会写的AI办公，包含百种Excel、Word、PPT工具，兼容WPS，百倍效率！★

之前五页快要测试完了

回复

shenjianrong163

TA的精华主题

TA的得分主题

发表于 2020-2-8 12:17 | 显示全部楼层

[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件 ★免费下载 ★ ★ 使用帮助★

Sub DeleteLastSlide()
Dim i&, j&, arr
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show Then myPath$ = .SelectedItems(1) Else Exit Sub
End With
If Right(myPath, 1) <> "" Then myPath = myPath & ""
Set d1 = CreateObject("Scripting.Dictionary")
Set d2 = CreateObject("Scripting.Dictionary")
d1(myPath) = ""
Set fso = CreateObject("Scripting.FileSystemObject")
Do While i < d1.Count
kr = d1.Keys
For Each f In fso.GetFolder(kr(i)).Files
If f.Name Like "*.ppt*" Then
j = j + 1: d2(j) = kr(i) & "" & f.Name
End If
Next
i = i + 1
For Each fd In fso.GetFolder(kr(i - 1)).SubFolders
d1(fd.Path) = " " & fd.Name & ""
Next
Loop
arr = d2.Items
If (UBound(arr) < 0) Then
MsgBox "当前目录下没有其它的PPT", 48, "警告"
Exit Sub
Else
For i = 0 To UBound(arr)
Set pptInput = Presentations.Open(arr(i), ReadOnly:=msoFalse)
With Application.Presentations(arr(i)).Windows(1)
If Not .Active Then
Set oldWin = Application.ActiveWindow
.Activate
End If
End With
ActivePresentation.Slides(ActivePresentation.Slides.Count).Delete
Presentations(arr(i)).Save
Presentations(arr(i)).Close
Next i
End If
End Sub

复制代码

回复

shenjianrong163

TA的精华主题

TA的得分主题

发表于 2020-2-8 12:26 | 显示全部楼层

[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★使用手册★

附件供参考：

ppt批量删除最后一页.rar (44.74 KB, 下载次数: 38)

回复

shenjianrong163

TA的精华主题

TA的得分主题

发表于 2020-2-8 13:41 | 显示全部楼层

[广告] ★Excel Home云课堂 - 专业的职场技能充电站★ ★Excel三大利器★ ★ 笨办法学VBA全系列★

Sub DeleteLastSlide()
Dim i&, j&, arr
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show Then myPath$ = .SelectedItems(1) Else Exit Sub
End With
If Right(myPath, 1) <> "" Then myPath = myPath & ""
Set d1 = CreateObject("Scripting.Dictionary")
Set d2 = CreateObject("Scripting.Dictionary")
d1(myPath) = ""
Set fso = CreateObject("Scripting.FileSystemObject")
Do While i < d1.Count
kr = d1.Keys
For Each f In fso.GetFolder(kr(i)).Files
If f.Name Like "*.ppt*" Then
j = j + 1: d2(j) = kr(i) & "" & f.Name
End If
Next
i = i + 1
For Each fd In fso.GetFolder(kr(i - 1)).SubFolders
d1(fd.Path) = " " & fd.Name & ""
Next
Loop
arr = d2.Items
If (UBound(arr) < 0) Then
MsgBox "当前目录下没有其它的PPT", 48, "警告"
Exit Sub
Else
For i = 0 To UBound(arr)
Set pptInput = Presentations.Open(arr(i), ReadOnly:=msoFalse)
With Application.Presentations(arr(i)).Windows(1)
If Not .Active Then
Set oldWin = Application.ActiveWindow
.Activate
End If
End With
ActivePresentation.Slides(ActivePresentation.Slides.Count).Delete
Presentations(arr(i)).Save
Presentations(arr(i)).Close
Next i
End If
End Sub

复制代码

回复

发新帖

最新热点 /1

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2024-4-19 23:43 , Processed in 0.043973 second(s), 12 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号沪ICP备11019229号-2

本论坛言论纯属发表者个人意见，任何违反国家相关法律的言论，本站将协助国家相关部门追究发言者责任！本站特聘法律顾问：李志群律师

快速回复 返回顶部 返回列表