有时候需要将一个word文档每一页另存为一个word文档，手工操作量大太繁琐。我们可以用VBA来实现批量自动处理。本文以word2010为例。查看宏（Alt+F8），创建宏“分页保存”，输入以下代码，然后执行宏“分页保存”即可。

本程序是每次删除多余的部分，因此不会改变原文的格式，页眉页脚也会保留完好。

注：开始时，需要处理的文档必须已经完全打开，页数显示正确之后开始执行宏。本程序分页的文档保存在源文档相同目录，请运行前把源文档单独放在一个目录下。

Sub 分页保存()

''分页保存,WORD2010下运行正常

''本代码在某页第一行是表格时会发生错误，应避免第一行是表格。

''开始时，需要处理的文档必须已经完全打开，页数显示正确之后开始执行程序

''本程序分页的文档保存在源文档相同目录，请运行前把源文档单独放在一个目录下

'

Application.ScreenUpdating = False '关闭屏幕更新

'声明

Dim x As Integer

Dim j As Integer

Dim n As Integer

Dim max As Integer

 

Dim ErrChar() As Variant, oChar As Variant

'文件自动命名时必须规避的字符,"/"

    ErrChar = Array("", ":", "*", "?", """", "<", ">", "|", vbTab, NullChar, vbCr, vbLf)

 

'获取当前文档完整路径

    ThisPath = ActiveDocument.Path

    ThisName = ActiveDocument.Name

    ThisName = ThisPath & "\" & ThisName

   ' MsgBox ThisName

    

'获取当前文档页数

max = ActiveDocument.BuiltInDocumentProperties(wdPropertyPages)

 

MsgBox "页数：" & CInt(max)

 

'对每一页循环

For j = 1 To max

 

    Dim str1 As String

 

       '在所需页尾插入特殊字符

        If j < max Then

        x = j + 1

        Selection.GoTo What:=wdGoToPage, Which:=wdGoToNext, Name:=x

        Selection.InsertAfter "卐卐"

        End If

 

        '在所需页首插入特殊字符

        If j > 1 Then

        Selection.GoTo What:=wdGoToPage, Which:=wdGoToNext, Name:=j

        Selection.InsertAfter "卍"

        End If

       

        '删除所需页尾之后的部分

        Selection.HomeKey unit:=wdStory

        

        If j < max Then

        With Selection.Find

           .Forward = True

           .Wrap = wdFindStop

           .Text = "卐卐"

          .Execute

        End With

        'Selection.Delete

        

        Selection.EndKey unit:=wdStory, Extend:=wdExtend

        Selection.Delete

        

        End If

        

        Selection.HomeKey unit:=wdStory

 

         '删除所需页首之前的部分

        If j > 1 Then

        With Selection.Find

           .Forward = True

           .Wrap = wdFindStop

           .Text = "卍"

          .Execute

        End With

          Selection.Delete

        Selection.HomeKey unit:=wdStory, Extend:=wdExtend

        Selection.Delete

        End If

 

 

        '获取第一行的文本

        Selection.HomeKey unit:=wdStory

        Selection.EndKey unit:=wdLine, Extend:=wdExtend

 

        str1 = Selection.Text

        str1 = Trim(str1)

      

        For Each oChar In ErrChar    '进行一系列替换,即删除无效字符

            str1 = Replace(str1, oChar, "")

        Next

        

        str1 = Replace(str1, " ", "")

        str1 = Replace(str1, "/", "╱")

        '生成文件名

        str1 = ThisPath & "\" & CInt(j) & str1 & ".doc"

        

        '另存为

        ActiveDocument.SaveAs FileName:=str1

       '关闭并重新打开文档

        ActiveDocument.Close

        Documents.Open FileName:=ThisName

 

Next j

 

ActiveDocument.Close

Application.ScreenUpdating = True    '恢复屏幕更新

 

End Sub