Sub 每N页分割为一个新文档__保存到同目录下()
'特别鸣谢"雨雪霏霏、守柔版主。
    Dim MyPath As String, PageCount As Integer
    Dim StartRange As Long, EndRange As Long, MyRange As Range
    Dim Fn As String, MyDoc As Document, i As Integer
    On Error Resume Next
    Application.ScreenUpdating = False
    MyPath = ActiveDocument.Path    '取得文档路径
    PageCount = Selection.Information(wdNumberOfPagesInDocument)    '取得文档总页数
    N = InputBox("按每几页拆分？默认为3：", "请输入数值", 3)
    Selection.HomeKey unit:=wdStory    '将光标移至文档起点
    For i = 1 To PageCount / N + (PageCount Mod N)    '设置循环次数，如3则表示每3页做一次循环
        StartRange = Selection.Start    '取得该页的第一个字符位置
        Selection.EndKey unit:=wdLine    '将光标移动到该页首行的最后位置
        Fn = i & ActiveDocument.Name    '-1的目的是防止该页首行含有段落标记,导致出错.
        If i * N >= PageCount Then    '如果循环到达最后一页
            EndRange = ActiveDocument.Content.End    '将文档最后位置赋值于EndRange
        Else
           For J = 1 To N
            Selection.GoToNext (wdGoToPage)
            Next J
            EndRange = Selection.Start
        End If
        Set MyRange = ActiveDocument.Range(StartRange, EndRange)  '将N页中的内容进行复制
        MyRange.Copy
        Set MyDoc = Documents.Add    '新建一空白文档
        With MyDoc
             .Content.Paste    '在新文档中粘贴
             .Content.Paragraphs.Last.Range.Delete '删除新文档末尾多出来的一个段落标记
             .SaveAs FileName:=MyPath & "/" & Fn
             '保存新文档到原文档所在目录。如果删除"MyPath & "/" & "，。则保存到"我的文档"中。
             .Close    '关闭新文档
        End With
    Next
    Application.ScreenUpdating = True
End Sub