请教：用vba怎么将一个大型文档按照指定页数进行分割？

怀英慕者

我有一份大型的文档，每两页内容一样，由于页数太多，领导又要求按照每两页一份文档进行分割，任务量太大，那么用VBA怎么实现呢？
问题已解决，代码请见6楼。

tangqingfu

本版上有相关代码，请认真查找。

sqhsqhli

Sub 每两页一文档()
Dim s%, mydoc
For s = 1 To ActiveDocument.Range.Information(wdNumberOfPagesInDocument) Step 2
With ActiveDocument
.Range(.GoTo(wdGoToPage, wdGoToNext, , s).Start, VBA.IIf(s >= .GoTo(wdGoToPage, wdGoToNext, , s).Information(wdNumberOfPagesInDocument), .Content.End, .GoTo(wdGoToPage, wdGoToNext, , s + 2).Start)).Copy
End With
Set mydoc = Documents.Add(Visible:=False)
With mydoc
.Content.Paste
.SaveAs s & ".doc" '此处偷工减料没有采用word默认文件名，直接数字了
.Close
End With
Set mydoc = Nothing
Next
End Sub

怀英慕者

sqhsqhli 发表于 2012-3-6 11:16
Sub 每两页一文档()
Dim s%, mydoc
For s = 1 To ActiveDocument.Range.Information(wdNumberOfPagesInDo ...

你好！非常感谢帮助！！！
我测试了一下，提示“数值超出范围”，有没有看到输出到什么地方，请赐教！

sqhsqhli

果然有错误，改成以下可以了。保存位置是word默认的位置，如果你安装office后没有设置过，它在“我的文档”。
运行宏以后，文件逐一命名为1.doc,3.doc,5.doc。。。。。,如果已经存在此文件，她将不会提示覆盖掉，所以请注意保存。

Sub 每两页一文档()
Dim s%, mydoc
For s = 1 To ActiveDocument.Range.Information(wdNumberOfPagesInDocument) Step 2
With ActiveDocument
.Range(.GoTo(wdGoToPage, wdGoToNext, , s).Start, VBA.IIf(s + 2 < ActiveDocument.Range.Information(wdNumberOfPagesInDocument), .GoTo(wdGoToPage, wdGoToNext, , s + 2).Start, .Content.End)).Copy
End With
Set mydoc = Documents.Add(Visible:=False)
With mydoc
.Content.Paste
.SaveAs s & ".doc" '此处偷工减料没有采用word默认文件名，直接数字了
.Close
End With
Set mydoc = Nothing
Next
End Sub

怀英慕者

sqhsqhli 发表于 2012-3-6 13:50
果然有错误，改成以下可以了。保存位置是word默认的位置，如果你安装office后没有设置过，它在“我的文档” ...

再次感谢你的热心帮助！！！！！
不过，我测试了一下还是有问题，后来实在是着急，又搜索了一下找到了另一个办法，我又根据我的实际情况添加了三行代码，已经解决了！
哈哈，还是很感谢你的！我把代码贴出来，请你也研究研究，也供其他朋友学习！

1. Sub 每两页分割为一个新文档__保存到同目录下()
   
2. '2010.01.30 雨雪霏霏改编自守柔版主代码。
   
3. '守柔版主代码见：《请教：如何将一个word文档按页保存为多个word文档？？？》5楼
   
4. '链接为：http://club.excelhome.net/viewthread.php?tid=52690
   
5. 
   
6. 
   
7.     Dim MyPath As String, PageCount As Integer
   
8.     Dim StartRange As Long, EndRange As Long, MyRange As Range
   
9.     Dim Fn As String, MyDoc As Document, i As Integer
   
10. 
    
11. 
    
12.     On Error Resume Next
    
13.     Application.ScreenUpdating = False
    
14. 
    
15.     MyPath = ActiveDocument.Path    '取得文档路径
    
16.     PageCount = Selection.Information(wdNumberOfPagesInDocument)    '取得文档总页数
    
17. 
    
18. 
    
19.     Selection.HomeKey Unit:=wdStory    '将光标移至文档起点
    
20.     For i = 1 To PageCount / 2 + (PageCount Mod 2)    '设置循环次数
    
21.         StartRange = Selection.Start    '取得该页的第一个字符位置
    
22.         Selection.EndKey Unit:=wdLine    '将光标移动到该页首行的最后位置
    
23.         Fn = i & ActiveDocument.Name    '-1的目的是防止该页首行含有段落标记,导致出错.
    
24.         If i * 2 >= PageCount Then    '如果循环到达最后一页
    
25.             EndRange = ActiveDocument.Content.End    '将文档最后位置赋值于EndRange
    
26.         Else
    
27.        '否则,将下两页的起始位置赋值于EndRange(等同于下一页的最后位置)
    
28.             Selection.GoToNext (wdGoToPage)
    
29.             Selection.GoToNext (wdGoToPage)
    
30.             EndRange = Selection.Start
    
31.         End If
    
32.         Set MyRange = ActiveDocument.Range(StartRange, EndRange)  '将两页中的内容进行复制
    
33.         MyRange.Copy
    
34. 
    
35. 
    
36.         Set MyDoc = Documents.Add    '新建一空白文档
    
37.         With MyDoc
    
38.              .Content.Paste    '在新文档中粘贴
    
39.              .Content.Paragraphs.Last.Range.Delete '删除新文档末尾多出来的一个段落标记
    
40.             
    
41.              Selection.EndKey Unit:=wdStory
    
42.              Selection.TypeBackspace
    
43.              Selection.Delete Unit:=wdCharacter, Count:=1
    
44.              '以上三行代码的作用是删除掉分割后的文档出现的末页空白页
    
45. 
    
46.              .SaveAs FileName:=MyPath & "/" & Fn
    
47.              '保存新文档到原文档所在目录。如果删除“MyPath & "/" & ”，。则保存到“我的文档”中。
    
48.              .Close    '关闭新文档
    
49.         End With
    
50.     Next
    
51. 
    
52. 
    
53.     Application.ScreenUpdating = True
    
54. End Sub

复制代码

怀英慕者

当然也非常感谢雨雪霏霏老师和守柔版主！！！！！！！！！

sqhsqhli

怀英慕者 发表于 2012-3-6 18:06
再次感谢你的热心帮助！！！！！
不过，我测试了一下还是有问题，后来实在是着急，又搜索了一下找到了另 ...

能告诉我出了什么问题嘛？我试了一个200多页的文档，还行的

szqhb

sqhsqhli 发表于 2012-3-6 13:50
果然有错误，改成以下可以了。保存位置是word默认的位置，如果你安装office后没有设置过，它在“我的文档” ...

将
.SaveAs s & ".doc" '此处偷工减料没有采用word默认文件名，直接数字了
改为
.SaveAs (s + 1) / 2 & ".doc" '此处偷工减料没有采用word默认文件名，直接数字了
则文件命名为1、2、3、4、5……

sqhsqhli

不偷工减料应该这样：
Sub 每两页一文档()
On Error Resume Next
Dim s%, mydoc
For s = 1 To ActiveDocument.Range.Information(wdNumberOfPagesInDocument) Step 2
With ActiveDocument
.Range(.GoTo(wdGoToPage, wdGoToNext, , s).Start, VBA.IIf(s + 2 < ActiveDocument.Range.Information(wdNumberOfPagesInDocument), .GoTo(wdGoToPage, wdGoToNext, , s + 2).Start, .Content.End)).Copy
End With
Set mydoc = Documents.Add(Visible:=False)
With mydoc
.Content.Paste
.SaveAs getfirstvisibletextcontent(mydoc) & ".doc" '此处偷工减料没有采用word默认文件名，直接数字了
.Close
End With
Set mydoc = Nothing
Next
End Sub
'获取指定行第一行可见文字
Function getfirstvisibletextcontent(odoc)
Dim oparagraph
Dim strcontent
For Each oparagraph In odoc.Paragraphs
strcontent = getsafefilename(oparagraph.Range.Text)
If Len(strcontent) <> 1 Then
getfirstvisibletextcontent = strcontent
Exit Function
End If
Next
getfirstvisibletextcontent = ""
End Function
'过滤文件名中的无效字符
Function getsafefilename(strfilename)
Dim arrunsafecharacters, strunsafechar
Dim nlndex
arrunsafecharacters = Array("\", "/", ":", "*", "?", """", "<", ">", "|")
For nlndex = 0 To &H2F
strfilename = Replace(strfilename, Chr(nlndex), "")
Next
For Each strunsafechar In arrunsafecharacters
strfilename = Replace(strfilename, strunsafechar, "")
Next
getsafefilename = Left(Trim(strfilename), 20)
'getsafefilename = Left(Trim(strfilename), g_ntitlemaxlen)
End Function