ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

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

[求助] VBA如何将WORD中内容按标题进行拆分成多个文档

[复制链接]

TA的精华主题

TA的得分主题

发表于 2021-2-18 14:53 | 显示全部楼层 |阅读模式
各位老师新年好!请教一下:VBA如何将WORD中内容按标题(一级标题)进行拆分成多个文档,且文件名用标题(一级)名进行命名,谢谢啦!

如何拆分.rar

118.35 KB, 下载次数: 71

TA的精华主题

TA的得分主题

发表于 2021-2-18 15:09 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
大纲里面有个按标题拆分文档的功能选项

TA的精华主题

TA的得分主题

发表于 2021-2-19 02:46 | 显示全部楼层
本帖最后由 413191246se 于 2021-2-28 23:41 编辑

略。。。。

TA的精华主题

TA的得分主题

 楼主| 发表于 2021-2-20 09:13 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
413191246se 发表于 2021-2-19 02:46
* 明老师 过年好!
* 楼主 过年好!——能不能让你的普通文档不要携带这么多宏呀!让普通文档成为一个纯粹 ...

谢谢老师,不知能否按一级标题拆分,且文件名以一级标题为文件名。

TA的精华主题

TA的得分主题

 楼主| 发表于 2021-2-20 09:16 | 显示全部楼层
413191246se 发表于 2021-2-19 02:46
* 明老师 过年好!
* 楼主 过年好!——能不能让你的普通文档不要携带这么多宏呀!让普通文档成为一个纯粹 ...

这个是上传的附件,请有时间时看看如何按一级标题进行拆分

家训.rar

11.89 KB, 下载次数: 48

TA的精华主题

TA的得分主题

发表于 2021-2-21 16:12 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
    MsgBox Word.ActiveDocument.Paragraphs(1).Style     MsgBox Word.ActiveDocument.Paragraphs(2).Style

TA的精华主题

TA的得分主题

发表于 2021-3-22 14:12 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
  1. Sub 按标题拆分文档()
  2. Application.ScreenUpdating = False
  3. Dim arr()
  4. Dim srr()
  5. Dim drr()
  6. Dim old
  7. Dim ioo
  8. Dim ppt
  9. Dim wdfullname
  10. Dim wdpath
  11. Dim i As Integer
  12. Dim wd As Document
  13. ioo = MsgBox("是否另存为pdf", vbYesNoCancel + vbInformation)
  14. If ioo = 2 Then Exit Sub
  15. Set wd = ActiveDocument
  16. wdpath = ActiveDocument.Path
  17. wdfullname = ActiveDocument.fullname
  18. drr() = Array("/", "", ":", "*", "?", """", "<", ">", "|", ChrW(13))
  19. Selection.HomeKey Unit:=wdStory
  20. Selection.Find.Style = "标题 1"
  21. Do While Selection.Find.Execute
  22. n = n + 1
  23. ReDim Preserve arr(1 To n)
  24. ReDim Preserve srr(1 To n)
  25. arr(n) = Selection.Range.Text
  26. For Each old In drr()
  27. arr(n) = Replace(arr(n), old, "")
  28. Next
  29. srr(n) = Selection.Information(wdActiveEndPageNumber)
  30. Loop
  31. For i = 1 To n
  32. If Dir(wdpath & "" & arr(i) & ".docx") <> "" Then
  33. MsgBox "当前路径存在和标题" & arr(i) & "重名的word文件,即将退出"
  34. Selection.HomeKey Unit:=wdStory
  35. Exit Sub
  36. End If
  37. If ioo = 6 Then
  38. If Dir(wdpath & "" & arr(i) & ".pdf") <> "" Then
  39. MsgBox "当前路径存在和标题" & arr(i) & "重名的pdf文件,即将退出"
  40. Selection.HomeKey Unit:=wdStory
  41. Exit Sub
  42. End If
  43. End If
  44. Next
  45. If MsgBox("是否先将当前文档保存一下", vbYesNo + vbInformation) = 6 Then ActiveDocument.Save
  46. For i = 1 To n
  47. wd.SaveAs2 wdpath & "" & arr(i) & ".docx"
  48. Next
  49. wd.Close
  50. For i = 1 To n
  51. Documents.Open wdpath & "" & arr(i) & ".docx"
  52. If i <> n Then
  53. Selection.GoTo What:=wdGoToPage, Which:=wdGoToNext, Name:=srr(i + 1)
  54. Selection.EndKey Unit:=wdStory, Extend:=wdExtend
  55. Selection.Delete
  56. End If
  57. If srr(i) <> 1 Then
  58. Selection.GoTo What:=wdGoToPage, Which:=wdGoToNext, Name:=srr(i)
  59. Selection.HomeKey Unit:=wdStory, Extend:=wdExtend
  60. Selection.Delete
  61. End If
  62. If ioo = 6 Then ActiveDocument.SaveAs2 wdpath & "" & arr(i), 17
  63. ActiveDocument.Close SaveChanges:=wdSaveChanges
  64. Next
  65. Set wd = Nothing
  66. If Documents.Count = 0 Then Application.Quit
  67. Application.ScreenUpdating = True
  68. End Sub
复制代码

评分

1

查看全部评分

TA的精华主题

TA的得分主题

发表于 2021-3-23 19:24 来自手机 | 显示全部楼层
betelehe 发表于 2021-3-22 14:12

谢谢分享。        

TA的精华主题

TA的得分主题

发表于 2022-1-5 19:56 | 显示全部楼层

您这个解决了吗?为什么我运行这个word后就没有呢

TA的精华主题

TA的得分主题

发表于 2022-1-6 14:58 | 显示全部楼层
tanshuizhu 发表于 2022-1-5 19:56
您这个解决了吗?为什么我运行这个word后就没有呢

直接用主控文档拆分就可以。大纲视图-全选-显示文档-创建-保存

评分

1

查看全部评分

您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

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

GMT+8, 2024-3-29 23:58 , Processed in 0.060699 second(s), 15 queries , Gzip On, Redis On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

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

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

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