将word文档按页拆分若干文档

首先打开要拆分的文档，然后按alt+f11（打开vb）在这里插入，模块，然后复制下列代码：

Option Explicit

Sub SplitPagesAsDocuments()

    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)
        oSrcDoc.Bookmarks("\page").Range.Copy
        oSrcDoc.Windows(1).Activate
        Application.Browser.Target = wdBrowsePage
        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 "结束！"

End Sub

注意：不要关闭该vb窗口，直接按f5执行就可以了。

不过那个是按单页拆分的。如果想按照指定页数拆分，请使用下面的代码，其它步骤和原来那个方案相同。

Option Explicit
 
Sub SplitEveryFivePagesAsDocuments()
    Dim oSrcDoc As Document, oNewDoc As Document
    Dim strSrcName As String, strNewName As String
    Dim oRange As Range
    Dim nIndex As Integer, nSubIndex As Integer, nTotalPages As Integer, nBound As Integer
    Dim fso As Object
   
    Const nSteps = 200         ' 修改这里控制每隔几页分割一次
   
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set oSrcDoc = ActiveDocument
    Set oRange = oSrcDoc.Content
   
    nTotalPages = ActiveDocument.Content.Information(wdNumberOfPagesInDocument)
    oRange.Collapse wdCollapseStart
    oRange.Select
    For nIndex = 1 To nTotalPages Step nSteps
        Set oNewDoc = Documents.Add
        If nIndex + nSteps > nTotalPages Then
            nBound = nTotalPages
        Else
            nBound = nIndex + nSteps - 1
        End If
        For nSubIndex = nIndex To nBound
            oSrcDoc.Activate
            oSrcDoc.Bookmarks("\page").Range.Copy
            oSrcDoc.Windows(1).Activate
             Application.Browser.Target = wdBrowsePage
            Application.Browser.Next
   
            oNewDoc.Activate
            oNewDoc.Windows(1).Selection.Paste
        Next nSubIndex
        strSrcName = oSrcDoc.FullName
        strNewName = fso.BuildPath(fso.GetParentFolderName(strSrcName), _
                     fso.GetBaseName(strSrcName) & "_" & (nIndex \ nSteps + 1) & "." & fso.GetExtensionName(strSrcName))
        oNewDoc.SaveAs strNewName
        oNewDoc.Close False
    Next nIndex
    Set oNewDoc = Nothing
    Set oRange = Nothing
    Set oSrcDoc = Nothing
    Set fso = Nothing
    MsgBox "结束！"
End Sub