PPT宏修改需求：拆分第3-20页幻灯片并按标题命名保存

以下是适配需求的修改代码，实现从第3到20页幻灯片拆分，并用幻灯片标题作为文件名保存，同时处理了文件名非法字符的问题：

Option Explicit
Sub TestMe()
    ' 替换为你的演示文稿实际路径
    SaveSpecificSlides "C:\Users\domino\Desktop\3_PPT\PPT_Macro\PAT_upgrade.pptx", True
End Sub

Sub SaveSpecificSlides(ByVal newFilename As String, _
                  Optional ByVal keepOpen As Boolean = False)
    Dim dotPosition As Long
    dotPosition = InStrRev(newFilename, ".")
    If dotPosition = 0 Then
        MsgBox "文件名缺少pptx扩展名"
        Exit Sub
    End If

    ' 创建单独文件夹保存拆分后的文件
    Dim saveFolder As String
    saveFolder = Left$(newFilename, dotPosition - 1) & "\"
    If Dir(saveFolder, vbDirectory) = "" Then
        MkDir saveFolder
    End If

    Dim newPresentation As Presentation
    Dim thisPresentation As Presentation
    Set thisPresentation = ActivePresentation

    Dim i As Long
    ' 限定处理范围：第3到20页
    For i = 3 To 20
        ' 防止超出演示文稿实际页数
        If i > thisPresentation.Slides.Count Then Exit For
        
        Set newPresentation = Presentations.Add
        thisPresentation.Slides(i).Copy
        With newPresentation
            .Slides.Paste Index:=1
            .Slides(1).Design = thisPresentation.Slides(i).Design
            .Slides(1).ColorScheme = thisPresentation.Slides(i).ColorScheme
            
            ' 获取幻灯片标题，兼容无标题的情况
            Dim slideTitle As String
            If thisPresentation.Slides(i).Shapes.HasTitle Then
                slideTitle = thisPresentation.Slides(i).Shapes.Title.TextFrame.TextRange.Text
            Else
                slideTitle = "幻灯片_" & Format(i, "00")
            End If
            
            ' 移除文件名非法字符
            slideTitle = ReplaceIllegalChars(slideTitle)
            
            ' 以标题为文件名保存
            .SaveAs FileName:=saveFolder & slideTitle & ".pptx"
            If Not keepOpen Then
                .Close
            End If
        End With
    Next i
End Sub

' 辅助函数：替换文件名中的非法字符
Function ReplaceIllegalChars(str As String) As String
    Dim illegalChars As Variant
    illegalChars = Array("\", "/", ":", "*", "?", """", "<", ">", "|")
    Dim char As Variant
    For Each char In illegalChars
        str = Replace(str, char, "")
    Next char
    ReplaceIllegalChars = str
End Function

关键修改说明： #

• 限定拆分范围：将循环范围从全量幻灯片改为3 To 20，同时增加页码校验避免超出实际页数
• 按标题命名：通过Shapes.HasTitle检查幻灯片是否有标题占位符，有则取标题文本，无则用默认序号名称
• 处理非法字符：新增ReplaceIllegalChars函数，移除文件名中不允许的特殊字符（如\、/、:等），避免保存失败
• 优化保存路径：自动创建与原文件同名的文件夹，统一存放拆分后的文件，更便于管理

使用注意事项： #

1. 替换TestMe子过程中的文件路径为你的演示文稿实际路径
2. 将演示文稿保存为.pptm格式（启用宏的演示文稿）才能运行代码
3. 如果幻灯片标题不在默认占位符中，需调整获取标题的代码（比如通过占位符索引查找）

内容的提问来源于stack exchange，提问作者i200yrs