Word 按表头拆分成多个文件

谢礼军

求大神帮忙把 这个Word中的 文件 按照表头拆分成单个的文档，如果能将拆分出来文档的名称改成相应的名称那就太完美了。翻遍本网站也没有找到可用的代码，感谢大神帮忙！！！！

谢礼军

此文档有些为1页，有些2页，有些3页 为一个完整的文档。

z9bhd

Sub lx()
    Dim wd1 As Document, wd As Document, m$
        Application.ScreenUpdating = False
        Set wd1 = ThisDocument
        Do
            Selection.EndKey unit:=wdStory
            With Selection.Find
                .Text = "文件名称"
                .Forward = False
                .Wrap = wdFindStop
                .Execute
                If .Found = True Then
                    Selection.MoveUp unit:=wdParagraph
                    Selection.EndKey unit:=wdStory, Extend:=wdExtend
                    Selection.Cut
                    Set wd = Documents.Add
                    wd.Range.Paste
                    m = wd.Tables(1).Range.Cells(2).Range.Text
                    m = Left(m, Len(m) - 2)
                    On Error Resume Next
                    If Dir(wd1.Path & "\拆分文件\") = "" Then MkDir (wd1.Path & "\拆分文件")
                    wd.SaveAs2 (wd1.Path & "\拆分文件\" & m & ".docx")
                    wd.Close
                Else
                    Exit Do
                End If
            End With
        Loop
        MsgBox "拆分完毕"
        Application.ScreenUpdating = True
End Sub

z9bhd

工作程序.zip (118.43 KB, 下载次数: 31)

2021-3-30 16:06 上传

点击文件名下载附件

谢礼军

z9bhd 发表于 2021-3-30 16:07

你好，辛苦了 大师，  昨天下午有其他事情 没有时间看， 刚才试了试，新建了一个空白的文档，然后显示“运行时错误，4065：”此命令无效。    我用的是 office 2016  。  是什么问题啊  大师？然后再次运行， 显示拆分完毕，还是空白文档。

z9bhd

谢礼军 发表于 2021-3-31 09:07
你好，辛苦了 大师，  昨天下午有其他事情 没有时间看， 刚才试了试，新建了一个空白的文档，然后显示“ ...

不要新建文档，直接在原文档中运行代码试试

z9bhd

z9bhd 发表于 2021-3-31 09:21
不要新建文档，直接在原文档中运行代码试试

我这里测试没问题

谢礼军

刚才 我又在另外的电脑安装的是office2007   上 完美运行， 怎么回事，大师

z9bhd

谢礼军 发表于 2021-3-31 09:29
刚才 我又在另外的电脑安装的是office2007   上 完美运行， 怎么回事，大师

这个问题我可真搞不懂，我用的是2010

谢礼军

z9bhd 发表于 2021-3-31 09:52
这个问题我可真搞不懂，我用的是2010

谢谢大师  我又找了一台安装 office2016的 电脑 测试  可以拆分，但是文档名称为  文件名1、文件名2.......，拆一个点一次确定， 你的截图是 文档名都是正确的，不是手动改的吧，实在不行   我装回2010 试试 ，  跪谢大师