考试想做个题库，题很多，遇到困难了

413191246se

gbgbxgb 老师，好久不见！我对老师的功夫是佩服得五体投地！请注意休息。

gbgbxgb

413191246se 发表于 2021-5-20 16:58
gbgbxgb 老师，好久不见！我对老师的功夫是佩服得五体投地！请注意休息。

有兴趣就参考下吧： 提取答案一例01.rar (14.81 KB, 下载次数: 35)

2021-5-20 17:17 上传

点击文件名下载附件

sylun

如果是纯文档处理，可试试如下代码：

1. Sub test()
   
2.     '假设题型说明及题干均只有一个段落，题型说明以小写汉字数字为序
   
3.     '按题号及选项字母后的标点均为顿号查找
   
4.     Dim data As String
   
5.     Dim RegExp As Object
   
6.    
   
7.     Application.ScreenUpdating = False
   
8.     data = ActiveDocument.Content.Text
   
9.     Set RegExp = CreateObject("VBScript.RegExp")
   
10.     With RegExp
    
11.         .Global = True
    
12.         .MultiLine = True
    
13.         .Pattern = "(^\d+、[^\r]+?)\s*\r(?!(A、|\d+、|[一二三四]、))"
    
14.         Do While .test(data) = True '合并异常段落
    
15.             data = .Replace(data, "$1")
    
16.         Loop
    
17.         .Pattern = "(^\d+、[^\r]+?)\(([A-D]+)\)(.+?^D、[^\r]+\r)"
    
18.         data = .Replace(data, "$1$3[答案]$2" & Chr(13) & Chr(13))
    
19.         If Right(data, 1) <> Chr(13) Then data = data & Chr(13)
    
20.         .Pattern = "(^\d+、)(\([√×]\))([^\r]+)(\r)"
    
21.         data = .Replace(data, "$1$3$2$4")
    
22.     End With
    
23.     Documents.Add(ActiveDocument.FullName).Content.Text = data
    
24.     Application.ScreenUpdating = True
    
25.     MsgBox "处理完毕！处理结果见新文档。", vbInformation
    
26. End Sub

复制代码