|
|
VBA：每两页分割为一个新文档__保存到同目录下
原帖由 秋日的枫叶 于 2010-1-28 22:31 发表 
如何把WORD每2页，分割成一个单独的word文件
很急，坛子里的都是每页WORD分割一个WORD
我需要按照2页分割一个WORD
请 秋日的枫叶 兄试试以下代码：
Sub 每两页分割为一个新文档__保存到同目录下()
'2010.01.30 雨雪霏霏改编自守柔版主代码。
'守柔版主代码见：《请教：如何将一个word文档按页保存为多个word文档？？？》5楼
'链接为：http://club.excelhome.net/viewthread.php?tid=52690
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) '取得文档总页数
Selection.HomeKey unit:=wdStory '将光标移至文档起点
For i = 1 To PageCount / 2 + (PageCount Mod 2) '设置循环次数
StartRange = Selection.start '取得该页的第一个字符位置
Selection.EndKey unit:=wdLine '将光标移动到该页首行的最后位置
Fn = i & ActiveDocument.Name '-1的目的是防止该页首行含有段落标记,导致出错.
If i * 2 >= PageCount Then '如果循环到达最后一页
EndRange = ActiveDocument.Content.End '将文档最后位置赋值于EndRange
Else
'否则,将下两页的起始位置赋值于EndRange(等同于下一页的最后位置)
Selection.GoToNext (wdGoToPage)
Selection.GoToNext (wdGoToPage)
EndRange = Selection.start
End If
Set MyRange = ActiveDocument.Range(StartRange, EndRange) '将两页中的内容进行复制
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
[ 本帖最后由 雨雪霏霏 于 2010-1-30 11:14 编辑 ] |
评分
-
1
查看全部评分
-
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2010-1-28 22:31
