段落排序

jiangxiaoyun

如上图，根据每个题目的第一个字母来将题目排序。
上面排序后的结果是 2 1  3，也就是 i  m  w。
目前能做到的方法是将所有段落文本放到数组里，重新排序，再放到word里面。
同时也标记黄色背景段落的id为特殊值，再遍历段落重新着色。
请问各位大神，是否有更好的方法。
谢谢！
段落排序.zip (14.98 KB, 下载次数: 9)

2021-3-12 11:50 上传

点击文件名下载附件

jiangxiaoyun

上个代码，直接开干的，效率一般。

1. Sub NewParagraphSort() '段落排序
   
2.     Application.ScreenUpdating = False
   
3.     Dim oldDoc As Document
   
4.     Set oldDoc = ActiveDocument
   
5.     Dim d As Object
   
6.     Set d = CreateObject("scripting.dictionary")
   
7.     Dim arr(65 To 90)
   
8.     For i = 65 To 90
   
9.         arr(i) = Chr(i)
   
10.         d(Chr(i)) = ""
    
11.     Next
    
12.     Dim newDoc As Document
    
13.     Set newDoc = Documents.Add
    
14.     p = oldDoc.Paragraphs.Count
    
15.     On Error Resume Next
    
16.     For x = 65 To UBound(arr)
    
17.         i = 0
    
18.         Do
    
19.             i = i + 1
    
20.             ttt = Trim(oldDoc.Paragraphs(i).Range.Text)
    
21.             If Len(ttt) > 1 Then
    
22.                 For j = 1 To Len(ttt)
    
23.                     t = UCase(Mid(ttt, j, 1))
    
24.                     If d.Exists(t) Then
    
25.                         t1 = t: Exit For
    
26.                     End If
    
27.                 Next
    
28.                 If t1 = arr(x) Then
    
29.                     Set arange = oldDoc.Range( _
    
30.                         Start:=oldDoc.Paragraphs(i).Range.Start, _
    
31.                         End:=oldDoc.Paragraphs(i + 5).Range.End)
    
32.                     With Application.Windows(newDoc).Selection
    
33.                         Selection.EndKey unit:=wdStory
    
34.                         .Range.FormattedText = arange
    
35.                     End With
    
36.                 End If
    
37.                 i = i + 5
    
38.             End If
    
39.         Loop Until i > p
    
40.     Next
    
41. End Sub

复制代码

shenjianrong163

对比下这个用时多少：

1. Sub test()
   
2.     Dim i%, j%, k%, n%, p%, t, temp, arr(1 To 10000, 1 To 3)
   
3.     Application.ScreenUpdating = False
   
4.     t = Timer
   
5.     k = 0
   
6.     With ActiveDocument
   
7.         n = .Paragraphs.Count '获取文档总段数
   
8.         For i = 1 To n
   
9.             If Len(.Paragraphs(i).Range.Text) > 1 Then
   
10.                 For j = i To n
    
11.                     If Len(.Paragraphs(j).Range.Text) = 1 Then
    
12.                         k = k + 1
    
13.                         For p = 1 To Len(.Paragraphs(i).Range.Text)
    
14.                             If .Paragraphs(i).Range.Characters(p).Text Like "[a-zA-Z]" Then
    
15.                                 arr(k, 1) = UCase(.Paragraphs(i).Range.Characters(p).Text)
    
16.                                 Exit For
    
17.                             End If
    
18.                         Next
    
19.                         arr(k, 2) = i
    
20.                         arr(k, 3) = j - 1
    
21.                         Exit For
    
22.                     End If
    
23.                 Next
    
24.                 i = j
    
25.             End If
    
26.         Next
    
27.         For i = 1 To k - 1
    
28.             For j = i + 1 To k
    
29.                 If arr(i, 1) > arr(j, 1) Then
    
30.                     For p = 1 To 3
    
31.                         temp = arr(i, p)
    
32.                         arr(i, p) = arr(j, p)
    
33.                         arr(j, p) = temp
    
34.                     Next
    
35.                 End If
    
36.             Next
    
37.         Next
    
38.         For i = 1 To k '按先后顺序复制到文档最后
    
39.             .Range(.Paragraphs(arr(i, 2)).Range.Start, .Paragraphs(arr(i, 3)).Range.End).Select '选中
    
40.             Selection.Copy '复制
    
41.             .Range.InsertParagraphAfter '在文档后插入一行
    
42.             Selection.EndKey Unit:=wdStory '光标移到文档尾
    
43.             Selection.Paste '粘贴
    
44.         Next
    
45.        .Range(.Paragraphs(1).Range.Start, .Paragraphs(n).Range.End).Select '选中原来的内容
    
46.         Selection.Delete '删除
    
47.     End With
    
48.     Application.ScreenUpdating = True
    
49.     MsgBox "处理完成!用时：" & Format(Timer - t, "0.000") & "秒!", "64", "温馨提示"
    
50. End Sub
    

复制代码

shenjianrong163

每题都是5行，可以减少一层循环：

1. Sub test()
   
2.     Dim i%, j%, k%, n%, p%, t, temp, arr(1 To 10000, 1 To 3)
   
3.     Application.ScreenUpdating = False
   
4.     t = Timer
   
5.     k = 0
   
6.     With ActiveDocument
   
7.         n = .Paragraphs.Count '获取文档总段数
   
8.         For i = 1 To n
   
9.             If Len(.Paragraphs(i).Range.Text) > 1 Then
   
10.                 k = k + 1
    
11.                 For j = 1 To Len(.Paragraphs(i).Range.Text)
    
12.                     If .Paragraphs(i).Range.Characters(j).Text Like "[a-zA-Z]" Then
    
13.                         arr(k, 1) = UCase(.Paragraphs(i).Range.Characters(j).Text)
    
14.                         Exit For
    
15.                     End If
    
16.                 Next
    
17.                 arr(k, 2) = i
    
18.                 arr(k, 3) = i + 4
    
19.                 i = i + 5
    
20.             End If
    
21.         Next
    
22.         For i = 1 To k - 1
    
23.             For j = i + 1 To k
    
24.                 If arr(i, 1) > arr(j, 1) Then
    
25.                     For p = 1 To 3
    
26.                         temp = arr(i, p)
    
27.                         arr(i, p) = arr(j, p)
    
28.                         arr(j, p) = temp
    
29.                     Next
    
30.                 End If
    
31.             Next
    
32.         Next
    
33.         For i = 1 To k '按先后顺序复制到文档最后
    
34.             .Range(.Paragraphs(arr(i, 2)).Range.Start, .Paragraphs(arr(i, 3)).Range.End).Select '选中
    
35.             Selection.Copy '复制
    
36.             .Range.InsertParagraphAfter '在文档后插入一行
    
37.             Selection.EndKey unit:=wdStory '光标移到文档尾
    
38.             Selection.Paste '粘贴
    
39.         Next
    
40.        .Range(.Paragraphs(1).Range.Start, .Paragraphs(n).Range.End).Select '选中原来的内容
    
41.         Selection.Delete '删除
    
42.     End With
    
43.     Application.ScreenUpdating = True
    
44.     MsgBox "处理完成!用时：" & Format(Timer - t, "0.000") & "秒!", "64", "温馨提示"
    
45. End Sub

复制代码

sylun

也可以试试如下遍历自动编号段落的方法

1. Sub test()
   
2.     '基于题目应用了特定的自动编号
   
3.     Dim i%, docend&, data$()
   
4.     Dim ListPara As Paragraph
   
5.    
   
6.     Application.ScreenUpdating = False
   
7.     With ActiveDocument
   
8.         docend = .Content.End
   
9.         For Each ListPara In .ListParagraphs
   
10.             If ListPara.Range.ListFormat.ListString Like "#*" Then
    
11.                 ReDim Preserve data(2, i)
    
12.                 data(1, i) = ListPara.Range.start
    
13.                 If i > 0 Then data(2, i) = data(1, i - 1) Else data(2, i) = .Range.End
    
14.                 data(0, i) = Trim(Replace(ListPara.Range.Text, Chr(9), ""))
    
15.                 i = i + 1
    
16.             End If
    
17.         Next
    
18.         WordBasic.SortArray data, 0, 0, UBound(data, 2), 1, 0
    
19.         For i = 0 To UBound(data, 2)
    
20.             .Bookmarks("\endofdoc").Range.FormattedText = .Range(data(1, i), data(2, i))
    
21.         Next
    
22.         .Range(0, docend - 1).Delete
    
23.     End With
    
24.    
    
25.     Application.ScreenUpdating = True
    
26.     MsgBox "共处理了" & UBound(data, 2) + 1 & "道题", vbInformation
    
27. End Sub

复制代码

wdpfox

学品高，人品强，耐心解答，好人平安！


段落排序.rar (15.12 KB, 下载次数: 3)

2021-3-15 14:01 上传

点击文件名下载附件

wdpfox

sylun 发表于 2021-3-13 15:24
也可以试试如下遍历自动编号段落的方法

程序运行后，多了个H，烦请查下原因，谢谢！

sylun

wdpfox 发表于 2021-3-15 14:05
程序运行后，多了个H，烦请查下原因，谢谢！

原代码13行确实有点问题，虽然在新文档输出处理结果没有影响。应改为
If i > 0 Then data(2, i) = data(1, i - 1) Else data(2, i) = .Range.End - 1
以下改为全部用变量docend的值（经修改），可再试试：

1. Sub test()
   
2.     '基于题目应用了特定的自动编号（阿拉伯数字）
   
3.     Dim i%, docend&, data$()
   
4.     Dim ListPara As Paragraph
   
5.    
   
6.     Application.ScreenUpdating = False
   
7.     With ActiveDocument
   
8.         docend = .Content.End - 1
   
9.         For Each ListPara In .ListParagraphs
   
10.             If ListPara.Range.ListFormat.ListString Like "#*" Then
    
11.                 ReDim Preserve data(2, i)
    
12.                 data(1, i) = ListPara.Range.start
    
13.                 If i > 0 Then data(2, i) = data(1, i - 1) Else data(2, i) = docend
    
14.                 data(0, i) = Trim(Replace(ListPara.Range.Text, Chr(9), ""))
    
15.                 i = i + 1
    
16.             End If
    
17.         Next
    
18.         WordBasic.SortArray data, 0, 0, UBound(data, 2), 1, 0
    
19.         For i = 0 To UBound(data, 2)
    
20.             .Bookmarks("\endofdoc").Range.FormattedText = .Range(data(1, i), data(2, i))
    
21.         Next
    
22.         .Range(0, docend).Delete
    
23.     End With
    
24.    
    
25.     Application.ScreenUpdating = True
    
26.     MsgBox "共处理了" & UBound(data, 2) + 1 & "道题", vbInformation
    
27. End Sub

复制代码

wdpfox

多谢老师分享好代码！