1000道选择题批量填入答案

kingtau

原题

先分析题目和答案，发现查找题目只有括号关键字最好找，查找别的关键字容易误选；
答案只有ABCDE五种；分析完成后分6步操作：

1、查找所有需要填内容的括号\(^s@\)，确认查找总数为1000处。

确认查找到1000处括号

2、任意文本中间插入seq域，随即将域剪切。

插入seq域

3、将查找的内容全部替换为与答案相似又可以区分的形式^c.G，并确认替换了1000处。

括号全部替换为域

4、全选文档，更新域；再次全选文档，将域转为普通文本。

更新域代码并转换为文本后

5、使用通配符替换1次，([0-9]@.)G(*)\1([A-E])替换为（ \3 ）\2。并将过程录制成宏。

替换

6、编辑宏代码，首尾加入循环语句For i = 1 To 1000  Next，循环1000次。全部过程大约10分钟。

加入循环后的宏代码

我是复印社老板，偶然机会接到这个活儿。
以前没接触到高级应用，无从下手，后疯狂在网上查资料，很遗憾没有找到现成的解决方案。
但是很多资料提供了思路，受益最大的当属《

WORD

常用查找与替换实例及方法

》作者：ipkh 这篇文章，文章水印www.excelhome.net 。
特注册账号来发扬互联网分享精神！
本人不是专家，以上内容欢迎大家参与讨论，优化流程或代码。

changhong8

代码如下，测试通过

daibao88

谢谢分享！辛苦了

changhong8

格式比较规范，正则获取每道题答案存入字典，再依次替换为答案，两步就行了，代码正在审核中

kingtau

changhong8 发表于 2019-10-27 17:19
格式比较规范，正则获取每道题答案存入字典，再依次替换为答案，两步就行了，代码正在审核中

谢谢，如果有专业的代码能直接简便搞定，那更好了，期待您的回复。
也许以后会经常遇到这种需要替换答案的情况

changhong8

如果括号里面的空白不规范就用特殊格式字符查询，改下查找替换部分代码就行了

kingtau

changhong8 发表于 2019-10-27 15:52
代码如下，测试通过

老师，我手工输入您的代码，是用错了地方，还是有输错的字符，运行完成后括号是空的，答案并没有填入。
我的word版本是2016专业增强版，请指导


Sub 填入答案()
Dim p As Paragraph
Set reg = CreateObject("vbscript.regexp")
Set d = CreateObject("scripting.dictionary")
istr = ThisDocument.Range
With reg
    .Pattern = "(\d+)\.([A-Ea-e])(?=\W)"
    .Global = True
    If .test(istr) Then
        Set mhs = .Execute(istr)
        For Each mh In mhs
            d(mh.submatches(0)) = mh.submatches(1)
        Next
    End If
End With
Selection.HomeKey wdStory
For i = 1 To 6
    strtext = strtext & ChrW(160)
Next
strtext = "(" & strtext & ")"
Do
    With Selection
        If .Find.Execute(strtext) Then
            Num = Num + 1
            .Range = "(" & d(CStr(Num)) & " )"
      Else
        Exit Do
      End If
    End With
Loop
End Sub

wdpfox

将thisdocument改为activedocument，即可。

                                        莫愁前路无知己，天下谁人不识君！只道是：海内存知己，天涯若比邻！  

kingtau

感谢@wdpfox，代码成功运行
感谢@changhong8的热心帮助10分钟的操作优化到几秒钟就可以完成

kingtau

经过月余的学习，将代码改进，现在只需要1.3秒就可以完成。

1. Sub 选择题秒填答案()
   
2. Dim arr, mh, rng As Range, n As Long, i%, t
   
3. t = Timer
   
4. Set rng = ActiveDocument.Range
   
5. rng.Find.Execute2007 FindText:="(      )", ReplaceWith:="(   )", Replace:=wdReplaceAll
   
6.     With CreateObject("vbscript.regexp")
   
7.             .Global = True
   
8.             .Pattern = "(\d+)\.([A-Ea-e])(?=\W)"
   
9.             Set arr = .Execute(rng)
   
10. '            .Pattern = "\(\u00A0{6}\)"
    
11.             .Pattern = "\(\s{3}\)"
    
12.             For Each mh In .Execute(rng)
    
13.                 n = mh.FirstIndex - 10
    
14.                 ActiveDocument.Range(n, n + 1) = arr(i).submatches(1)
    
15.                 i = i + 1
    
16.             Next
    
17.     End With
    
18. MsgBox Timer - t
    
19. End Sub

复制代码