word按页批量另存为（指定文件名）

vianchiang

求助大神：我有一个word文档，里面有很多页，每一页格式都是一样的，现在想要把每一页另存为一个单独的word文档，以每一页中的渠道名称命名，就是每一页左上方和右下角都有的渠道名称。求教，该怎么实现？

vianchiang

搬个小板凳等待大神眷顾

dyx790106

先用本论坛守柔兄的代码，粘贴于活动文档中（即你的主文档中）的“THISDOCUMENT”模块中：
Sub SaveAsPage()
Dim PageCount As Integer, StartRange As Long, EndRange As Long, MyRange As Range, Fn As String, MyDoc As Document
On Error Resume Next
PageCount = Selection.Information(wdNumberOfPagesInDocument)
Range(0, 0).Select '将光标移至文档起点
For i = 1 To PageCount '设置循环次数
    StartRange = Selection.Start '取得该页的第一个字符位置
    Selection.EndKey Unit:=wdLine '将光标移动到该页首行的最后位置
    Fn = i & ActiveDocument.Name '-1的目的是防止该页首行含有段落标记,导致出错.
        If i = PageCount Then '如果循环到达最后一页
        EndRange = ActiveDocument.Content.End '将文档最后位置赋值于EndRange
        Else
        Selection.GoToNext (wdGoToPage) '否则,将下一页的起始位置赋值于EndRange(等同于本页的最后位置)
        EndRange = Selection.Start
        End If
    Set MyRange = Range(StartRange, EndRange) '将本页中的内容进行复制
    MyRange.Copy
    Set MyDoc = Documents.Add '新建一空白文档
    MyDoc.Range(0, 0).Paste '在文档开始处粘贴
    MyDoc.SaveAs FileName:=Fn '保存文档名
    MyDoc.Close '关闭文档
Next
End Sub
然后再用批量重命名，就可以实现了

假定你的目录是d:\sample，先进命令提示行用
dir d:\sample /s /b *.*  > d:\dir.txt
将目录列表输出至dir.txt
然后用记事本打开上面的dir.txt，复制，选中excel中的C2，粘贴

现在B列应该是新的文件名，C列是目录名

在d2输入="Ren """&c2& """ """&b2&".docx"""""
选中C1到C列的最后一行，比如C1到C100

复制C列数据，在记事本中保存为一个批处理文件，即.bat文件，然后双击运行这个bat

dyx790106

先用代码将文件存为单独文件，再用批量重命名来改名。

vianchiang

dyx790106 发表于 2015-3-10 10:32
先用本论坛守柔兄的代码，粘贴于活动文档中（即你的主文档中）的“THISDOCUMENT”模块中：
Sub SaveAsPage ...

非常感谢，已经做好了！(づ￣ 3￣)づ

vianchiang

dyx790106 发表于 2015-3-10 10:32
先用本论坛守柔兄的代码，粘贴于活动文档中（即你的主文档中）的“THISDOCUMENT”模块中：
Sub SaveAsPage ...

我今天重新运行这段代码，居然出错了。。。不知道怎么回事。提示子过程或函数未定义，能帮我看看吗？

vianchiang

dyx790106 发表于 2015-3-10 10:32
先用本论坛守柔兄的代码，粘贴于活动文档中（即你的主文档中）的“THISDOCUMENT”模块中：
Sub SaveAsPage ...

上个月还是好好的，真奇怪

dyx790106

vianchiang 发表于 2015-4-8 17:31
我今天重新运行这段代码，居然出错了。。。不知道怎么回事。提示子过程或函数未定义，能帮我看看吗？

Sub SaveAsPage()
Dim PageCount As Integer, StartRange As Long, EndRange As Long, MyRange As Range, Fn As String, MyDoc As Document
On Error Resume Next
PageCount = Selection.Information(wdNumberOfPagesInDocument)
ActiveDocument.Range(0, 0).Select '将光标移至文档起点
For i = 1 To PageCount '设置循环次数
    StartRange = Selection.Start '取得该页的第一个字符位置
    Selection.EndKey Unit:=wdLine '将光标移动到该页首行的最后位置
    Fn = i & ActiveDocument.Name '-1的目的是防止该页首行含有段落标记,导致出错.
        If i = PageCount Then '如果循环到达最后一页
        EndRange = ActiveDocument.Content.End '将文档最后位置赋值于EndRange
        Else
        Selection.GoToNext (wdGoToPage) '否则,将下一页的起始位置赋值于EndRange(等同于本页的最后位置)
        EndRange = Selection.Start
        End If
    Set MyRange = ActiveDocument.Range(StartRange, EndRange) '将本页中的内容进行复制
    MyRange.Copy
    Set MyDoc = Documents.Add '新建一空白文档
    MyDoc.Range(0, 0).Paste '在文档开始处粘贴
    MyDoc.SaveAs FileName:=Fn '保存文档名
    MyDoc.Close '关闭文档
Next
End Sub

dyx790106

vianchiang 发表于 2015-4-8 17:31
我今天重新运行这段代码，居然出错了。。。不知道怎么回事。提示子过程或函数未定义，能帮我看看吗？

将Range(0, 0).Select 修改为ActiveDocument.Range(0, 0).Select
将Set MyRange = Range(StartRange, EndRange) 修改为
  Set MyRange = ActiveDocument.Range(StartRange, EndRange)

雪天雨天晴天

dyx790106 发表于 2015-4-13 10:32
将Range(0, 0).Select 修改为ActiveDocument.Range(0, 0).Select
将Set MyRange = Range(StartRange, E ...

大神，word文档，想要把每4页另存为一个单独的word文档。求教，该怎么实现？