Word文档，按节拆分为多个单独文档

通过VBS 和 分节符 拆分 一个word文档为多个。

在网上看了半天只有按页拆分的，没有按节拆分，自己有需要就写了一个。

首先要确保的是你的word文档有分节符。

1. 打开需要拆分的word文档

2. 按ALT+F11打开VBA编辑器，并点击“插入-模块”。

3.粘贴下面的代码

Option Explicit

Sub SplitDocumentBySections()
    Dim oSrcDoc As Document
    Dim oNewDoc As Document
    Dim oSection As Section
    Dim oRange As Range
    Dim strSrcName As String
    Dim strNewName As String
    Dim nIndex As Integer
    Dim fso As Object
    Dim oHeader As HeaderFooter
    Dim oFooter As HeaderFooter

    Set fso = CreateObject("Scripting.FileSystemObject")
    Set oSrcDoc = ActiveDocument
    strSrcName = oSrcDoc.FullName

    nIndex = 1

    ' 创建新文档并复制原文档的样式
    Set oNewDoc = Documents.Add(Template:=oSrcDoc.AttachedTemplate.FullName, DocumentType:=0)
    oNewDoc.UpdateStylesOnOpen = False
    oNewDoc.UpdateStyles
    
    For Each oSection In oSrcDoc.Sections
        ' 复制分节内容和格式
        Set oRange = oSection.Range
        oRange.End = oRange.End - 1  ' 减去一个字符以避开分节符本身
        
        ' 清空新文档内容，准备粘贴新的分节
        oNewDoc.Content.Delete
        oRange.Copy
        oNewDoc.Content.PasteAndFormat (wdFormatOriginalFormatting)
        
        ' 复制页眉和页脚
        For Each oHeader In oSection.Headers
            If oHeader.Exists Then
                oHeader.Range.Copy
                oNewDoc.Sections(1).Headers(oHeader.Index).Range.PasteAndFormat (wdFormatOriginalFormatting)
            End If
        Next oHeader
        
        For Each oFooter In oSection.Footers
            If oFooter.Exists Then
                oFooter.Range.Copy
                oNewDoc.Sections(1).Footers(oFooter.Index).Range.PasteAndFormat (wdFormatOriginalFormatting)
            End If
        Next oFooter

        ' 构造新文档的文件名
        strNewName = fso.BuildPath(fso.GetParentFolderName(strSrcName), fso.GetBaseName(strSrcName) & "_Section" & nIndex & "." & fso.GetExtensionName(strSrcName))
        
        ' 保存并关闭新文档
        oNewDoc.SaveAs2 FileName:=strNewName, FileFormat:=oSrcDoc.SaveFormat
        nIndex = nIndex + 1
    Next oSection

    ' 清理
    oNewDoc.Close False
    Set oNewDoc = Nothing
    Set oRange = Nothing
    Set oSrcDoc = Nothing
    Set fso = Nothing

    MsgBox "拆分完成!"
End Sub

4. 点击“运行”，或按F5运行，等待运行“拆分完成！”。

5. 会在后缀添加个section，保存在原文档目录下。