【word】使用VBA代码，自定义页面数拆分大Word文件为多个小文档并指定名称保存

使用VBA代码，自定义页面数拆分大Word文件为多个小文档并指定名称保存

alt+F11打开开发选项-->选择【插入】-->【模块】-->弹出代码编辑窗口，插入下面代码，按照需要修改页数和要重命名的每个文档按顺序的名字--->按F5运行代码，文档最后就生成在当前目录下了

在word的某些版本上可能出现格式不对，最后测试在最新的wps上跑效果最好

Option Explicit
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Sub SplitEveryFivePagesAsDocuments()
On Error GoTo Errorhandler
Dim oSrcDoc As Document, oNewDoc As Document
Dim nameArray As Variant

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 = 4                          '设置多少页分割一次
nameArray = Array("Cat", "Dog", "Rabbit") '数组内容修改为需要的命名

Set fso = CreateObject("Scripting.FileSystemObject")
Set oSrcDoc = ActiveDocument
Set oRange = oSrcDoc.Content

nTotalPages =Val(ActiveDocument.BuiltInDocumentProperties(wdPropertyPages))
oRange.Collapse wdCollapseStart
oRange.Select
For nIndex = 1 To nTotalPages Step nSteps

    If nIndex + nSteps > nTotalPages Then
        nBound = nTotalPages
    Else
        nBound = nIndex + nSteps - 1
    End If

    Set oNewDoc = Documents.Add
    For nSubIndex = nIndex To nBound
        oSrcDoc.Activate
        oSrcDoc.Bookmarks("\page").Range.Copy
        oSrcDoc.Windows(1).Activate
        Application.Browser.Target = wdBrowsePage
        Application.Browser.Next
        Sleep 10
        oNewDoc.Activate
        oNewDoc.Windows(1).Selection.Paste
        Errorhandler:
            If Err = 4605 Then
                oNewDoc.Windows(1).Selection.Paste
            Else
                Resume Next
            End If
    MsgBox "nSubIndex" & "_" & nSubIndex
    Next nSubIndex
    strSrcName = oSrcDoc.FullName
    strNewName = fso.BuildPath(fso.GetParentFolderName(strSrcName), _
    fso.GetBaseName(strSrcName) & "_" & nameArray(nIndex\nSteps) & "." & fso.GetExtensionName(strSrcName))
    oNewDoc.SaveAs strNewName
    oNewDoc.Close False

MsgBox nameArray(nIndex\nSteps)
Next nIndex
Set oNewDoc = Nothing
Set oRange = Nothing
Set oSrcDoc = Nothing
Set fso = Nothing
MsgBox "结束！"
End Sub