分割【節】Word

Sub SplitSectionsAsDocuments()
'
' 分文件
'
'
    Dim oSrcDoc As Document, oNewDoc As Document
    Dim strSrcName As String, strNewName As String
    Dim oRange As Range
    Dim nIndex As Integer
    Dim fso As Object
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set oSrcDoc = ActiveDocument
    Set oRange = oSrcDoc.Content


    oRange.Collapse wdCollapseStart
    oRange.Select


    'For nIndex = 1 To ActiveDocument.Content.Information(wdNumberOfPagesInDocument)
    For nIndex = 1 To (ActiveDocument.Sections.Count) - 1
        'oSrcDoc.Bookmarks("\page").Range.Copy
        oSrcDoc.Bookmarks("\section").Range.Copy
        oSrcDoc.Windows(1).Activate
        Application.Browser.Target = wdBrowseSection
        Application.Browser.Next
        strSrcName = oSrcDoc.FullName
        strNewName = fso.BuildPath(fso.GetParentFolderName(strSrcName), _
                     fso.GetBaseName(strSrcName) & "_" & nIndex & "." & fso.GetExtensionName(strSrcName))
        Set oNewDoc = Documents.Add
        Selection.Paste
        oNewDoc.SaveAs strNewName
        oNewDoc.Close False
    
    Next


    Set oNewDoc = Nothing
    Set oRange = Nothing
    Set oSrcDoc = Nothing
    Set fso = Nothing
    


    MsgBox "匯出" + CStr((ActiveDocument.Sections.Count) - 1) + " 筆資料，結束！"


End Sub