ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

EH搜索     
EH云课堂-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
Excel不给力? 何不试试FoxTable! Excel 2016函数公式学习大典 EH云课堂直播课程免费学 打造核心竞争力的职场宝典
300集Office 2010微视频教程 Tableau-数据可视化工具 精品推荐-800套精选PPT模板,点击获取 ExcelHome出品 - VBA代码宝免费下载
你的Excel 2010实战技巧学习锦囊 欲罢不能, 过目难忘的 Office 新界面 Excel VBA经典代码实践指南
查看: 1258|回复: 19

[原创] 1000道选择题批量填入答案

[复制链接]

TA的精华主题

TA的得分主题

发表于 2019-10-27 11:42 | 显示全部楼层 |阅读模式
本帖最后由 kingtau 于 2019-10-27 11:45 编辑

原题

原题
微信截图_20191026115220.png

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


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

确认查找到1000处括号

确认查找到1000处括号


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

插入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
特注册账号来发扬互联网分享精神!
本人不是专家,以上内容欢迎大家参与讨论,优化流程或代码。



2019年护师试卷20191009.zip

134.02 KB, 下载次数: 58

示例文档

TA的精华主题

TA的得分主题

发表于 2019-10-27 15:52 | 显示全部楼层
本帖最后由 changhong8 于 2019-10-27 17:48 编辑

代码如下,测试通过

评分

参与人数 1鲜花 +2 收起 理由
kingtau + 2 感谢帮助

查看全部评分

TA的精华主题

TA的得分主题

发表于 2019-10-27 17:00 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2019-10-27 17:19 来自手机 | 显示全部楼层
格式比较规范,正则获取每道题答案存入字典,再依次替换为答案,两步就行了,代码正在审核中

TA的精华主题

TA的得分主题

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

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

TA的精华主题

TA的得分主题

发表于 2019-10-27 20:37 | 显示全部楼层
本帖最后由 changhong8 于 2019-10-27 20:39 编辑

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

TA的精华主题

TA的得分主题

 楼主| 发表于 2019-10-28 07:55 | 显示全部楼层
changhong8 发表于 2019-10-27 15:52
代码如下,测试通过

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

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

TA的精华主题

TA的得分主题

发表于 2019-10-28 11:32 | 显示全部楼层
将thisdocument改为activedocument,即可。




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

    评分

    参与人数 1鲜花 +2 收起 理由
    kingtau + 2 感谢帮助

    查看全部评分

    TA的精华主题

    TA的得分主题

     楼主| 发表于 2019-10-28 12:05 | 显示全部楼层
    感谢@wdpfox,代码成功运行
    感谢@changhong8的热心帮助[em07]10分钟的操作优化到几秒钟就可以完成[em07]

    TA的精华主题

    TA的得分主题

     楼主| 发表于 2019-12-2 12:42 | 显示全部楼层
    经过月余的学习,将代码改进,现在只需要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
    复制代码



    评分

    参与人数 2鲜花 +4 收起 理由
    zhanglei1371 + 2 值得肯定
    cuanju + 2 值得肯定

    查看全部评分

    您需要登录后才可以回帖 登录 | 免费注册

    本版积分规则

    关闭

    最新热点上一条 /1 下一条

    关注官方微信,高效办公专列,每天发车

    手机版|关于我们|联系我们|ExcelHome

    GMT+8, 2020-2-22 22:40 , Processed in 0.433778 second(s), 18 queries , Gzip On, MemCache On.

    Powered by Discuz! X3.4

    © 1999-2020 Wooffice Inc.

       

    沪公网安备 31011702000001号 沪ICP备11019229号

    本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:徐怀玉律师 李志群律师

    快速回复 返回顶部 返回列表