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

1042271867

各位老师新年好！请教一下：VBA如何将WORD中内容按标题（一级标题）进行拆分成多个文档，且文件名用标题（一级）名进行命名，谢谢啦！

ming0018

大纲里面有个按标题拆分文档的功能选项

413191246se

略。。。。

1042271867

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

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

1042271867

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

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

QQ214189912

    MsgBox Word.ActiveDocument.Paragraphs(1).Style     MsgBox Word.ActiveDocument.Paragraphs(2).Style

betelehe

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

复制代码

wdpfox

betelehe 发表于 2021-3-22 14:12

谢谢分享。        

tanshuizhu

wdpfox 发表于 2021-3-23 19:24
谢谢分享。

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

一闪流溢

tanshuizhu 发表于 2022-1-5 19:56
您这个解决了吗？为什么我运行这个word后就没有呢

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