word VBA按分节符拆分文档

Sub 根据分节符拆分文档()

    '本段代码作用: 如果没有分节符,提示后退出
    If Word.ActiveDocument.Sections.Count <= 1 Then
        MsgBox "拆分文档前请插入分节符!"
        Exit Sub
    End If


    '本段代码作用: 选择拆分后要保存的文件夹'
    Dim dia As FileDialog
    Set dia = Application.FileDialog(msoFileDialogFolderPicker)
    dia.Title = "请选择拆分后要保存的文件夹"
    If Word.ActiveDocument.Saved Then dia.InitialFileName = Word.ActiveDocument.path
    If dia.Show = 0 Then Exit Sub
    Dim sPath As String
    sPath = dia.SelectedItems(1)
    
    
    '本段代码作用:拆分文档并保存
    Dim oDoc As Document
    Dim nDoc As Document
    Set oDoc = Word.ActiveDocument
    Dim i As Long
    Dim j As Long
    j = oDoc.Sections.Count
    For i = 1 To j
        oDoc.Sections(i).Range.Copy   '复制一节内容'
        Set nDoc = Word.Documents.Add    '新建文档'
        nDoc.Content.PasteAndFormat (wdFormatOriginalFormatting) '按源格式粘贴到新文档
        nDoc.PageSetup = oDoc.Sections(i).PageSetup   '复制原文档页面设置
        Call 删除分节符
        nDoc.SaveAs2 sPath & "\" & oDoc.Name & "_" & i & ".docx"   '保存
        nDoc.Close   '关闭新文档'
    Next
End Sub

Function 删除分节符()

    Selection.HomeKey Unit:=wdStory
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
    .Text = "^b"
    .Replacement.Text = ""
    .Forward = True
    .Wrap = wdFindContinue
    .Format = True
    .MatchCase = False
    .MatchWholeWord = False
    .MatchWildcards = False
    .MatchSoundsLike = False
    .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    
End Function