如何用代码把红线句子提取到文末并随机排列

zzpsx

如何用代码把红线句子提取到文末并随机排列 如何把红线句子提取到文末并随机排列.rar (23.77 KB, 下载次数: 10)

2021-1-23 20:51 上传

点击文件名下载附件

413191246se

* 楼主，请将附件示例文档中的“想得到的效果如下”及以后的文字删除，保存后；
* 选定要处理的文字范围，应用下面的宏：

1. Sub aaaa下划线_提取句子到文末_随机排列()
   
2.     Dim r As Range, s As Range, n&, t$
   
3.     With Selection
   
4.         If .Type = 1 Then MsgBox "Not-Select!", 0 + 16: End
   
5.         If .Text Like "*" & vbCr & vbCr Then .Characters.Last.Delete
   
6.         If .Paragraphs.Last.Range.End < ActiveDocument.Content.End Then
   
7.             If .Next.Text = vbCr Then .Next.Delete
   
8.         End If
   
9.         With Selection
   
10.             Set r = .Range
    
11.             Set s = .Range
    
12.         End With
    
13.         With r.Find
    
14.             .ClearFormatting
    
15.             .Text = ""
    
16.             .Font.Underline = wdUnderlineSingle
    
17.             .Forward = True
    
18.             .MatchWildcards = True
    
19.             Do While .Execute
    
20.                 With .Parent
    
21.                     n = n + 1
    
22.                     t = t & "/" & .Text
    
23.                     .Text = Space(3) & n & Space(3)
    
24.                     .SetRange Start:=.End, End:=s.End
    
25.                 End With
    
26.             Loop
    
27.         End With
    
28.     End With
    
29.    
    
30.     With ActiveDocument.Content
    
31.         .InsertAfter Text:=vbCr & vbCr & t
    
32.         .Paragraphs.Last.Range.Select
    
33.     End With
    
34.     With Selection
    
35.         .Find.Execute "/", , , 0, , , , , , "^p", 2
    
36.         .MoveStart
    
37.         .ConvertToTable Separator:=wdSeparateByParagraphs, NumColumns:=1, AutoFitBehavior:=wdAutoFitFixed
    
38.         .Tables(1).Style = "网格型"
    
39.         .InsertColumnsRight
    
40.         .Tables(1).Select
    
41.         .Tables(1).AutoFitBehavior (wdAutoFitWindow)
    
42.         .Tables(1).Columns(2).Select
    
43.         Dim c As Cell
    
44.         For Each c In .Cells
    
45.             c.Range.Text = Rnd()
    
46.         Next
    
47.         .Tables(1).Select
    
48.         .Sort ExcludeHeader:=False, FieldNumber:="列 2", SortFieldType:= _
    
49.         wdSortFieldNumeric, SortOrder:=wdSortOrderAscending, FieldNumber2:="", _
    
50.         SortFieldType2:=wdSortFieldSyllable, SortOrder2:=wdSortOrderAscending, _
    
51.         FieldNumber3:="", SortFieldType3:=wdSortFieldSyllable, SortOrder3:= _
    
52.         wdSortOrderAscending, Separator:=wdSortSeparateByCommas, SortColumn:= _
    
53.         False, CaseSensitive:=False, LanguageID:=wdSimplifiedChinese, _
    
54.         SubFieldNumber:="段落数", SubFieldNumber2:="段落数", SubFieldNumber3:="段落数"
    
55.         .Tables(1).Columns(2).Delete
    
56.         .Tables(1).Select
    
57.         .Rows.ConvertToText Separator:=wdSeparateByParagraphs, NestedTables:=False
    
58.     End With
    
59.     With Selection
    
60.         .Previous(4, 1).Delete
    
61.         .Next(4, 1).Delete
    
62.     End With
    
63. '    Stop
    
64.     With ListGalleries(wdNumberGallery).ListTemplates(1).ListLevels(1)
    
65.         .NumberFormat = "%1."
    
66.         .TrailingCharacter = wdTrailingTab
    
67.         .NumberStyle = wdListNumberStyleUppercaseLetter
    
68.         .NumberPosition = CentimetersToPoints(0)
    
69.         .Alignment = wdListLevelAlignLeft
    
70.         .TextPosition = CentimetersToPoints(0.74)
    
71.         .TabPosition = wdUndefined
    
72.         .ResetOnHigher = 0
    
73.         .StartAt = 1
    
74.         .LinkedStyle = ""
    
75.     End With
    
76.     ListGalleries(wdNumberGallery).ListTemplates(1).Name = ""
    
77.     Selection.Range.ListFormat.ApplyListTemplateWithLevel ListTemplate:= _
    
78.         ListGalleries(wdNumberGallery).ListTemplates(1), ContinuePreviousList:= _
    
79.         False, ApplyTo:=wdListApplyToSelection, DefaultListBehavior:= _
    
80.         wdWord10ListBehavior
    
81. End Sub

复制代码

shenjianrong163

1. Public Sub test()
   
2.     Dim i%, j%, d, arr(), brr()
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     Application.ScreenUpdating = False
   
5.     Selection.HomeKey Unit:=wdStory '光标移到文档开始
   
6.     With Selection.Find
   
7.         .ClearFormatting
   
8.         .Font.ColorIndex = wdRed '查找红色字体
   
9.         .Forward = True
   
10.         Do While .Execute
    
11.             i = i + 1 '用来记录查找到的个数
    
12.             ReDim Preserve arr(1 To i)
    
13.             arr(i) = .Parent
    
14.             .Parent.Text = Space(3) & i & Space(3) '替换查找到的内容
    
15.         Loop
    
16.     End With
    
17.     ReDim brr(1 To UBound(arr))
    
18.     For i = 1 To UBound(brr) '随机生成1-UBound(brr)的整数
    
19. Loo:   j = Int(VBA.Rnd() * (UBound(brr) - 1 + 1) + 1)
    
20.         If Not d.Exists(j) Then
    
21.             d(p) = ""
    
22.             brr(i) = j
    
23.         Else
    
24.             GoTo Loo:
    
25.         End If
    
26.     Next
    
27.     For i = 1 To UBound(brr)
    
28.         ActiveDocument.Range.InsertParagraphAfter '在文档后插入一行
    
29.         Selection.EndKey Unit:=wdStory '光标移到文档尾
    
30.         ActiveDocument.Paragraphs(ActiveDocument.Paragraphs.Count).Range = Chr(64 + i) & "." & Space(2) & arr(brr(i)) '在最后一段输出内容
    
31.     Next
    
32.     Application.ScreenUpdating = True
    
33.     MsgBox "处理完成!", "64", "温馨提示"
    
34. End Sub

复制代码

shenjianrong163

附件供参考：


如何把红线句子提取到文末并随机排列.rar (38.34 KB, 下载次数: 11)

2021-1-26 21:58 上传

点击文件名下载附件

wang-way

shenjianrong163 发表于 2021-1-26 21:58
附件供参考：

优秀，向您学习