将word文档按分页另存为多个word文件的VBA代码,不改变原文的格式
2014-09-29 11:32阅读：
有时候需要将一个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
