求提取试题库答案，如何提取颜色为红色的答案

考试加油站

求提取答案 ，看附件，将答案提取到题后，用括号存起来
体脂管理师测考内容.rar (20.4 KB, 下载次数: 118)

2018-2-6 15:33 上传

点击文件名下载附件

duquancai

1. 详见楼下代码，如果与楼主的需求存在“出入”，请自行修改，不要再追问！

复制代码

duquancai

以此为准！请测试》》》》》》》》》》》》》

1. Sub test()
   
2.     Dim myStart&, myDoc As Document, b As Boolean, Q As Range, R As Range, sr$
   
3.     Application.ScreenUpdating = False
   
4.     Set myDoc = ActiveDocument
   
5.     With myDoc.Content.Find
   
6.         Do While .Execute("^13[0-9]@[.、．]", , , -1, , , 0)
   
7.             With .Parent
   
8.                 If Not b Then
   
9.                     Set Q = myDoc.Range(.Start + 1, myDoc.Content.End)
   
10.                     Set R = Q.Duplicate
    
11.                     With R.Find
    
12.                         .Font.ColorIndex = 6
    
13.                         Do While .Execute("*", , , -1)
    
14.                             If Not R.InRange(Q) Then Exit Do
    
15.                             sr = sr & R.Text
    
16.                         Loop
    
17.                         With Q
    
18.                             If sr <> "" Then
    
19.                                 .End = .End - 1: .InsertAfter "（" & sr & "）": sr = Empty
    
20.                             End If
    
21.                         End With
    
22.                     End With
    
23.                     b = True
    
24.                 Else
    
25.                     Set Q = myDoc.Range(.Start + 1, myStart)
    
26.                     Set R = Q.Duplicate
    
27.                     With R.Find
    
28.                         .Font.ColorIndex = 6
    
29.                         Do While .Execute("*", , , -1)
    
30.                             If Not R.InRange(Q) Then Exit Do
    
31.                             sr = sr & R.Text
    
32.                         Loop
    
33.                         With Q
    
34.                             If sr <> "" Then
    
35.                                 .End = .End - 1: .InsertAfter "（" & sr & "）": sr = Empty
    
36.                             End If
    
37.                         End With
    
38.                     End With
    
39.                 End If
    
40.                 myStart = .Start + 1: .Collapse
    
41.             End With
    
42.         Loop
    
43.     End With
    
44.     Application.ScreenUpdating = True
    
45.     MsgBox "ok!"
    
46. End Sub

复制代码

wdpfox

谢谢杜老师的代码，学习中。

相见是缘8

duquancai 发表于 2018-2-6 21:58
以此为准！请测试》》》》》》》》》》》》》

大神、有不有办法让这个提取的答案变一下颜色，提取的多个答案之间加一个空格？现提取的多个答案中，答案与答案之间大挤了。

ammyc

好好学习天天向上

常扬帆

楼主：用查找替换，什么颜色任选，如果自定义，RGB自己确定。