vba拆分word文档

同心/ty

求大神分享word文档拆分代码，docx文件有300页，我想无损的按每2页拆分成多个word文档保存，文件名在原文件名的基础上增加1取名。如：原文件名为“数据.docx”,拆分后文件名为：数据-1.docx  数据-2.docx   ......      

gwjkkkkk

请参考附件。。。

同心/ty

gwjkkkkk 发表于 2023-12-26 19:47
请参考附件。。。

老师，我测试了一下，代码很好！能达到我想要的效果。谢谢！

wang-way

gwjkkkkk 发表于 2023-12-26 19:47
请参考附件。。。

里面的代码消失了 ？

gwjkkkkk

wang-way 发表于 2024-1-7 21:07
里面的代码消失了 ？

重新下载一个试试。。。

wang-way

gwjkkkkk 发表于 2024-1-7 21:33
重新下载一个试试。。。

下过两回了 还是没有

gwjkkkkk

Option Explicit
Sub TEST2()
    Dim i&, Rng As Range, iStart&, iEnd&, n&, iPageNum&
    Dim strFileName$, strPath$, strPreName$, Items As FileDialogSelectedItems
   
    strPath = ThisDocument.Path & "\"
    With Application.FileDialog(1)
        With .Filters
            .Clear
            .Add "Excel Files", "*.doc?"
        End With
        .AllowMultiSelect = False
        .InitialFileName = strPath
        If .Show Then Set Items = .SelectedItems Else Exit Sub
    End With
   
    strPreName = Right(Items(1), Len(Items(1)) - InStrRev(Items(1), "\"))
    If strPreName = ThisDocument.Name Then Exit Sub
    strPreName = Left(strPreName, InStrRev(strPreName, ".") - 1)
   
    Application.ScreenUpdating = False
    With Documents.Open(Items(1))
        iPageNum = .Range.Information(wdNumberOfPagesInDocument)
        For i = 1 To iPageNum Step 2
            iStart = i
            iEnd = IIf(i = iPageNum, iPageNum, i + 1)
            Set Rng = .GoTo(wdGoToPage, Which:=wdGoToAbsolute, Count:=iStart)
            Selection.GoTo wdGoToPage, Which:=wdGoToAbsolute, Count:=iEnd
            With Rng
                If iEnd = iPageNum Then
                    .SetRange .Start, Selection.Bookmarks("\page").End
                Else
                    .SetRange .Start, Selection.Bookmarks("\page").End - 1
                End If
                .Select
                .Copy
            End With
            n = n + 1
            strFileName = strPath & strPreName & "-" & n
            With Documents.Add
                .Content.Paste
                .SaveAs strFileName
                .Close
            End With
        Next i
         .Close False
     End With
      
    Application.ScreenUpdating = True
    Beep
End Sub