VBA宏按“标题1”自动拆分word文档

Sub SplitDocByHeading1()
    Dim srcDoc As Document
    Dim newDoc As Document
    Dim para As Paragraph
    Dim rng As Range
    
    Dim startPos As Long
    Dim tempHeadingText As String
    Dim currentHeadingText As String
    Dim savePath As String
    Dim isFirstHeading As Boolean
    
    ' 获取当前文档
    Set srcDoc = ActiveDocument
    
    ' 直接获取当前文档所在的目录
    savePath = srcDoc.Path
    
    ' 如果文档尚未保存，提示用户先保存
    If savePath = "" Then
        MsgBox "当前文档尚未保存，请先保存文档后再运行此宏！", vbExclamation
        Exit Sub
    End If
    
    ' 确保路径末尾有反斜杠 "\"
    If Right(savePath, 1) <> "\" Then savePath = savePath & "\"
    
    Application.ScreenUpdating = False ' 关闭屏幕刷新提升速度
    Application.DisplayAlerts = wdAlertsNone ' 关闭警告提示
    
    isFirstHeading = True
    startPos = 0
    currentHeadingText = ""
    
    ' 遍历源文档的所有段落
    For Each para In srcDoc.Paragraphs
        
        ' 检查当前段落样式是否为“标题 1”
        If para.Style.NameLocal = "标题 1" Or para.Style.NameLocal = "Heading 1" Then
            
            ' 提取当前遍历到的标题文本
            tempHeadingText = para.Range.Text
            tempHeadingText = Left(tempHeadingText, Len(tempHeadingText) - 1) ' 去除末尾回车符
            
            If isFirstHeading Then
                ' 如果是文档中的第一个标题1，记录起始位置和标题名
                startPos = para.Range.Start
                currentHeadingText = tempHeadingText
                isFirstHeading = False
            Else
                ' 遇到新的标题1，将【上一个标题】到当前标题之前的内容提取出来
                Set rng = srcDoc.Range(startPos, para.Range.Start)
                
                ' 新建文档并复制内容
                Set newDoc = Documents.Add
                rng.Copy
                ' 保留原有格式粘贴
                newDoc.Range.PasteAndFormat wdFormatOriginalFormatting
                
                ' 【关键修正】使用 currentHeadingText (即上一个标题的文本) 命名
                newDoc.SaveAs2 FileName:=savePath & CleanFileName(currentHeadingText) & ".docx", FileFormat:=wdFormatXMLDocument
                newDoc.Close SaveChanges:=wdDoNotSaveChanges
                
                ' 更新下一个文档的起始位置和当前对应的标题名
                startPos = para.Range.Start
                currentHeadingText = tempHeadingText
            End If
        End If
    Next para
    
    ' 处理文档最后一个标题1的内容（循环结束后剩余的部分）
    If Not isFirstHeading Then
        Set rng = srcDoc.Range(startPos, srcDoc.Range.End)
        Set newDoc = Documents.Add
        rng.Copy
        newDoc.Range.PasteAndFormat wdFormatOriginalFormatting
        ' 使用 currentHeadingText (即最后一个标题的文本) 命名
        newDoc.SaveAs2 FileName:=savePath & CleanFileName(currentHeadingText) & ".docx", FileFormat:=wdFormatXMLDocument
        newDoc.Close SaveChanges:=wdDoNotSaveChanges
    End If
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = wdAlertsNone
    
    MsgBox "文档拆分完成！" & vbCrLf & "保存路径：" & savePath, vbInformation
End Sub

' 辅助函数：清理文件名中的非法字符（\ / : * ? " < > |）
Function CleanFileName(strName As String) As String
    Dim invalidChars As String
    Dim i As Integer
    invalidChars = "\/:*?""<>|"
    
    For i = 1 To Len(invalidChars)
        strName = Replace(strName, Mid(invalidChars, i, 1), "_")
    Next i
    
    ' 如果标题为空，给一个默认名字
    If Trim(strName) = "" Then strName = "未命名标题"
    
    CleanFileName = strName
End Function