ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
300集Office 2010微视频教程 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
查看: 793|回复: 2

[求助] WORD按关键字分页的代码优化问题

[复制链接]

TA的精华主题

TA的得分主题

发表于 2017-8-7 23:46 | 显示全部楼层 |阅读模式
邮件合并后,只有一个word文档,(因为EXCEL数据源只有一行),但是这个word文档大概有18页,现在要想实现合并后的文档拆分成4和个文档,分别以1.交易公告,2.报名表,3.承诺书.4.交易文件来命名保存在一个文件夹内。PS:第一个文档第一页的内容有首两个出现的字作为拆分的关键字“交易公告”,第二个文档第一页内容有首两个字关键字“报名表”作为拆分的依据,依次类推……第三个文档“承诺书”,第四个文档“交易文件”,请大神写出厉害的VBA代码,感激不尽,非诚勿扰。附上以下的代码(请看1楼),但是这个代码可能需要优化 ,因为运行的时候有时候可以有时候不可以,请高手帮忙修改!

TA的精华主题

TA的得分主题

 楼主| 发表于 2017-8-7 23:47 | 显示全部楼层
Sub Word以多个关键字拆分单个文档()

   Dim i As Integer, n As Integer, doxt, Document, dox As Document

   Dim Arr, Brr(), rng As Word.Range

   Word.Application.ScreenUpdating = False

   Arr = Array("黄埔区", "报名表", "承诺书", "交易文件")

   ReDim Brr(UBound(Arr) + 1)

   For i = 0 To UBound(Arr, 1)

      With ThisDocument.Content.Find

         .Text = "<" & Arr(i) & ">"

         .MatchWildcards = True

         Do While .Execute

            If i Then

               Brr(n) = .Parent.Previous(4, 1).End

            Else

               Brr(n) = .Parent.Start

            End If

            n = n + 1

         Loop

         If Not i = (n - 1) Then MsgBox Arr(i) & "  未查找到,退出": GoTo go_goo

      End With

   Next

   Brr(n) = ThisDocument.Content.End

   For i = 0 To UBound(Arr, 1)

      Set doxt = ThisDocument.Range(Brr(i), Brr(i + 1))

      doxt.Copy

      Set dox = Documents.Add(ThisDocument.FullName)

      With dox

         .Content.Delete

         .Content.Paste

       Set rng = .Paragraphs(.Paragraphs.Count).Range

      If Len(rng) = 1 Then rng.Delete

      If Len(rng) = 0 Then rng.Delete

   .SaveAs ThisDocument.Path & "" & Arr(i) & ".doc"

  .Close True

End With

Next i

MsgBox "拆分成了 " & n & " 文档"

go_goo:

  Word.Application.ScreenUpdating = True

   Set Arr = Nothing: Set rng = Nothing

  Set doxt = Nothing: Set dox = Nothing

End Sub

TA的精华主题

TA的得分主题

 楼主| 发表于 2017-8-9 12:15 来自手机 | 显示全部楼层
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2024-3-28 21:10 , Processed in 0.027589 second(s), 9 queries , Gzip On, Redis On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

快速回复 返回顶部 返回列表