如何将多页的word文档,每页都另存为一个单一的word文档

发布网友发布时间：2022-04-26 12:32

共3个回答

热心网友时间：2022-06-21 11:10

页数比较少的话，可以利用删除另存的方法来实现；

页数多的话可以利用宏来实现，参考以下代码：

Sub SplitEveryOnePagesAsDocuments()
    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 = 1         ' 修改这里控制每隔几页分割一次

    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

热心网友时间：2022-06-21 11:10

只能打开文档,留下要保存的一页文档,其他的都删除,然后另存为,后面的以此类推.追问8000多页呢

追答这可不好做,word不像excel好单个保存啊

热心网友时间：2022-06-21 11:10

不多的话一页一页复制保存到另外的word吧