按篇目顺序对word文档中的篇目重新排序

偶然古月照江北 · 发表于 2021-1-24 03:25

记事本LIST.TXT中是篇目顺序列表，文档“职责.doc”中的篇目标题都是二级标题，怎样按记事本中列表的顺序把word文档中的篇目重排，所有格式不变。

不经意的回头 · 发表于 2021-1-24 09:29

打开【导航窗格】，直接拖动导航窗格中的标题调整顺序就可以了。

413191246se · 发表于 2021-1-24 09:48

本帖最后由 413191246se 于 2021-1-24 09:50 编辑

* 楼主，以 Word 2019 为例，打开你的 Word 文档后，找到：视图——大纲——显示级别：2 级——将光标放在“校长岗位职责”这一行，点击“上移”按钮（↑），直到移至最上面一行；然后，将光标放在“副校长岗位职责”这一行，点击“上移”按钮（↑）或“下移”按钮。。。最后，点击“视图菜单”——页面视图——返回正常编辑状态。
* 原来版主大人已经回答了！我没看到，回答完才看到。

偶然古月照江北 · 发表于 2021-1-25 22:00

不经意的回头发表于 2021-1-24 09:29
打开【导航窗格】，直接拖动导航窗格中的标题调整顺序就可以了。

谢谢！这个方法我知道，我是想能不能用VBA一键解决？

偶然古月照江北 · 发表于 2021-1-25 22:01

413191246se 发表于 2021-1-24 09:48
* 楼主，以 Word 2019 为例，打开你的 Word 文档后，找到：视图——大纲——显示级别：2 级——将光标放在 ...

谢谢你的解决方案，我的思路是想用VBA一键解决

shenjianrong163 · 发表于 2021-1-26 18:31

'这个贴我在Excel VBA中已经回复过了：
Sub test()
Dim i%, j%, d, s, arrByte() As Byte
Set d = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
FileName = ThisDocument.Path & "" & Dir(ThisDocument.Path & "" & "*.txt") '获取当前目录下的txt文件
If Len(Dir(ThisDocument.Path & "" & "*.txt")) Then '判断是否存在txt文件
Open FileName For Binary Access Read As #1
ReDim arrByte(LOF(1) - 1)
Get #1, , arrByte
Close #1
s = Split(ByteToStr(arrByte, "UTF-8"), vbNewLine) '调用ByteToStr函数
Else
MsgBox "当前目录下没有txt文件!": Exit Sub '当前目录下没有txt文件,退出程序
End If
If UBound(s) < 0 Then MsgBox "txt文件中没有数据!": Exit Sub 'txt文件中没有内容,退出程序
For i = 0 To UBound(s)
d(Trim(s(i))) = ""
Next
t = ""
j = ThisDocument.Paragraphs.Count '获取文档总段数
For i = 1 To ThisDocument.Paragraphs.Count
If d.Exists(Replace(ThisDocument.Paragraphs(i).Range.Text, Chr(13), "")) Then
t = Replace(ThisDocument.Paragraphs(i).Range.Text, Chr(13), "")
d(t) = Array(i, i) '第一个参数记录段落开始
Else
If t <> "" Then d(t) = Array(d(t)(0), i) '第二个参数记录段落结束
End If
Next
i = 0
For Each tt In d.Keys '按先后顺序复制到文档最后
ThisDocument.Range(ThisDocument.Paragraphs(d(tt)(0)).Range.Start, ThisDocument.Paragraphs(d(tt)(1)).Range.End).Select '选中
Selection.Copy '复制
If i = 0 Then
ThisDocument.Range.InsertParagraphAfter '在文档后插入一行
i = i + 1
End If
Selection.EndKey Unit:=wdStory '光标移到文档尾
Selection.Paste '粘贴
Next
ThisDocument.Range(ThisDocument.Paragraphs(1).Range.Start, ThisDocument.Paragraphs(j).Range.End).Select '选中原来的内容
Selection.Delete '删除
Application.ScreenUpdating = True
MsgBox "处理完成!", "64", "温馨提示"
End Sub
Function ByteToStr(arrByte, strCharset As String) As String 'ByteToStr函数读取UTF-8或Unicode编码的内容
With CreateObject("Adodb.Stream")
.Type = 1
.Open
.Write arrByte
.Position = 0
.Type = 2
.Charset = strCharset
ByteToStr = .Readtext
.Close
End With
End Function

复制代码

413191246se · 发表于 2021-1-26 21:52

* 刚才我试了半天，可以做到的是：选定“校长岗位职责”以及它下面若干段落后，可以用一句VBA代码（其实按键就是 Alt+Shift+上箭头的代码化）上移到文首（此时，文本格式并未变化），但是下面再查找“副校长岗位职责”，就找不到了，找到的是“总务主任岗位职责”，查找失灵了！不知何故。——我开始也想到的是楼主可能是想用 VBA 的。

413191246se · 发表于 2021-1-26 23:31

* 问题解决！原来是 chr(10）惹的祸！请楼主同时打开两篇示例文档后应用下面的宏：

Sub aaaa篇目重新排序_校长岗位职责()
Dim arr, i As Paragraph, j&
Documents("职责.doc").Activate
With ActiveDocument.Content
.InsertAfter Text:=vbCr & "aaaa"
.Paragraphs.Last.Style = wdStyleHeading2
End With
arr = Split(Documents("list.txt").Content, vbCr)
For j = 0 To UBound(arr) - 1
With Selection
.HomeKey 6
ref:
.Find.Execute Replace(arr(j), Chr(10), "")
If .Start = .Paragraphs(1).Range.Start Then
Do
.MoveEnd 4
Loop Until .Next(4, 1).Style = "标题 2"
.Cut
.EndKey 6
.TypeParagraph
.Paste
Else
.MoveRight
GoTo ref
End If
.HomeKey 6
End With
Next
With ActiveDocument
For Each i In .Paragraphs
If Len(i.Range) = 1 Then i.Range.Delete
Next
.Paragraphs(1).Range.Delete
End With
End Sub

复制代码

偶然古月照江北 · 发表于 2021-1-29 13:28

413191246se 发表于 2021-1-26 23:31
* 问题解决！原来是 chr(10）惹的祸！请楼主同时打开两篇示例文档后应用下面的宏：

谢谢！请问：运行时，说文件名无效，并产生了一个“aaaa”的二级标题，文档中的几个职责没有重新排序呢

偶然古月照江北 · 发表于 2021-1-29 13:40

shenjianrong163 发表于 2021-1-26 18:31

谢谢！运行时提示当前目录下没有txt文件

		自动登录	找回密码
密码			免费注册

[求助] 按篇目顺序对word文档中的篇目重新排序