ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 效率神器,一键搞定繁琐工作
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
让更多数据处理,一键完成 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
查看: 1399|回复: 27

[求助] 试卷提取答案,回填答案

[复制链接]

TA的精华主题

TA的得分主题

发表于 2024-2-16 20:32 来自手机 | 显示全部楼层 |阅读模式
本帖最后由 hcy1185 于 2024-2-19 08:44 编辑

春节后安全知识培训试卷(计财科).rar (22 KB, 下载次数: 24)
试卷原题中包含完整答案,如何用VBA代码把原题中的答案提取出来,放在文档最后,按大小题序号排列好,第二段代码把答案填到原题中。试卷包括两行标题,试卷一至五大题,一填空题,二单项选择题,三多项选择题,四判断题,五简答题。一至四题的答案在()内,内容两端靠近()的内侧各1个空格,谢谢!

TA的精华主题

TA的得分主题

发表于 2024-2-17 08:33 | 显示全部楼层
需要附件                                                                                                                    

TA的精华主题

TA的得分主题

发表于 2024-2-17 15:26 来自手机 | 显示全部楼层
需要提供两个文档,一个原始的,一个手工模拟处理一小部分的。

TA的精华主题

TA的得分主题

发表于 2024-2-18 09:47 | 显示全部楼层
本帖最后由 过客fppt 于 2024-2-18 20:10 编辑
  1. Sub 批量调整答案到每道题目末端()
  2.     Dim l, j As Long
  3.     Dim rng, rng1 As Range
  4.     Dim newDoc As Document
  5.     Dim isNo1 As Boolean
  6.     Dim timustr, daanstr As String
  7.    
  8.     timustr = "试题"
  9.     daanstr = "参考答案:^p"
  10.    
  11.     Call 查找(daanstr, 0, 1)
  12.     If Selection.Find.Found = False Then
  13.         MsgBox "查找不到:" & daanstr
  14.         Exit Sub
  15.     End If
  16.     Call 自动查询题量
  17.     Set newDoc = Documents.Add(ActiveDocument.FullName)
  18.    
  19.     Call 查找(daanstr, 0, 1)
  20.     j = Selection.Range.Start
  21.     Set rng1 = ActiveDocument.Range(j, ActiveDocument.Content.End)
  22.     rng1.Select
  23.    
  24.     '    Call 全部替换("【分析】*【详解】", "【解答】", True)
  25.     Call 全部替换("(^p[0-9]{1,3})([..、])", "\1.【答案】", True)
  26.     rng1.Font.Color = wdColorBlue
  27.     rng1.Font.Name = "幼圆"
  28.     rng1.Font.Bold = False
  29.    
  30.     Selection.HomeKey Unit:=wdStory, Extend:=wdMove '回到文档的起点
  31.     Dim Index As Integer
  32.    
  33.     isNo1 = True
  34.     timuCount = timuCount / 2 - 1
  35.     For Index = 1 To timuCount
  36.         If isNo1 Then
  37.             '            Call 查找(timustr, 0, 1)
  38.             If Selection.Find.Found = False Then
  39.                 MsgBox "查找不到 " & timustr
  40.                 Exit Sub
  41.             End If
  42.             isNo1 = False
  43.         End If
  44.         Call 识别题干和答案区域并选中(Index)
  45.         If Selection.Find.Found = False Then
  46.             MsgBox "查找不到第 " & Index & " 题的题干!"
  47.             Exit For
  48.         End If
  49.         l = Selection.Range.End + 1
  50.         
  51.         Call 查找(daanstr, 0, 1)
  52.         Call 识别题干和答案区域并选中(Index)
  53.         If Selection.Find.Found = False Then
  54.             MsgBox "查找不到第 " & Index & " 题的答案!"
  55.             Exit For
  56.         End If
  57.         
  58.         If 是否重复(1) = 1 Then
  59.             Exit For
  60.         End If
  61.         Set rng = Selection.Range
  62.         Selection.SetRange Start:=l, End:=l
  63.         Selection.TypeParagraph '回车
  64.         ActiveDocument.Range(l, l).FormattedText = rng '.FormattedText
  65.         Selection.SetRange Start:=l, End:=l
  66.         rng.Delete
  67.     Next Index
  68.     Selection.HomeKey Unit:=wdStory, Extend:=wdMove '回到文档的起点
  69.     Call 全部替换(daanstr, "", True)
  70.     Call 全部替换("^p[0-9]{1,3}[..、]【答案】", "^p【答案】", 1)
  71.     Call 全部替换("解析", "解答", False)
  72.    
  73.     MsgBox "已完成" & Index & " 道题的答案转移到每道题后!"
  74. End Sub
复制代码


这是我新手期写的,但是只对某些特定格式的文档有用,你可以根据你的文档进行修改对应的子过程,子过程如下:
  1. Function 查找(文本, 通配符, 向下)
  2.     If Len(文本) <= 1 Then
  3.         MsgBox "警告:只查找一个字符,每次只能找到第一个!"
  4.     End If
  5.     Dim rng As Range
  6.     '    Set rng = IIf(Len(Selection.Range.text) <= 1, ActiveDocument.Content, Selection.Range)
  7.    
  8.     Selection.Find.ClearFormatting
  9.     With Selection.Find
  10.         .text = 文本
  11.         .Forward = 向下
  12.         .Wrap = wdFindContinue '往复查找
  13.         .MatchWildcards = 通配符
  14.     End With
  15.     Selection.Find.Execute
  16.     Selection.Find.Parent.Select
  17.     '    Set rng = Nothing
  18.    
  19. End Function
复制代码
  1. Function 自动查询题量()
  2.     '
  3.     ' Macro1 Macro
  4.     ' 宏由 ZPL 录制,时间: 2022/11/19
  5.     '
  6.     Dim j As Long    '记录第一个题号光标位置
  7.     Dim k As Long    '记录第最后一个题号光标位置
  8.     'Public timuCount As Integer '记录总题量(全局变量要在函数外定义)
  9.     Dim i As Integer
  10.     Do
  11.         If i <= 0 Then
  12.             Call 查找("^p[0-9]{1,3}[..、]", True, True)
  13.             j = Selection.Range.Start + 4
  14.             i = i + 1
  15.             
  16.         Else
  17.             Call 查找("^p[0-9]{1,3}[..、]", True, True)
  18.             k = Selection.Range.Start + 4
  19.             i = i + 1
  20.         End If
  21.         
  22.     Loop Until j = k
  23.    
  24.     timuCount = i - 1
  25.     自动查询题量 = timuCount
  26. End Function
复制代码
  1. Function 全部替换(原文字, 替换为, 通配符)
  2.     ' 宏由 ZPL 录制,时间: 2022/12/07
  3.     Dim rng As Range
  4.     Set rng = IIf(Len(Selection.Range.text) <= 1, ActiveDocument.Content, Selection.Range)
  5.     rng.Find.ClearFormatting
  6.     With rng.Find
  7.         .text = 原文字
  8.         .Forward = True
  9.         .Wrap = wdFindStop 'Wrap = wdFindAsk(找到会弹出提示框)'Wrap = wdFindStop(完成替换会停止)
  10.         .MatchCase = False 'True 指定要查找的文本应区分大小写。
  11.         .MatchByte = False   '搜索期间区分全角和半角字母或字符,则此属性返回 True ;否则返回 False 。 将属性值设置为 True 或 False 以启用或禁用该功能。
  12.         .MatchWildcards = 通配符 '通配符开关
  13.         .MatchWholeWord = False '真 要查找只整个单词,全字匹配。
  14.         .MatchFuzzy = False '确定 Microsoft Word 在搜索过程中是否对日语文本使用非特定搜索选项
  15.         .Replacement.text = 替换为
  16.     End With
  17.     rng.Find.Execute Replace:=wdReplaceAll
  18.     全部替换 = rng.Find.Found
  19.     rng.Find.ClearFormatting
  20.    
  21. End Function
复制代码
  1. Function 识别题干和答案区域并选中(index1 As Integer)
  2.    
  3.     Dim k1, k2, j1, j2 As Long
  4.     Dim timurng, daanrng As Range
  5.     Dim b As Integer
  6.    
  7.     Call 查找("^p" & index1 & "[..、]*^p" & index1 + 1 & "[..、]", True, 1)
  8.     识别题干和答案区域并选中 = Selection.Find.Found
  9.     k1 = Selection.Range.Start
  10.     k2 = Selection.Range.End
  11.     j1 = k1 + 1
  12.     Selection.SetRange Start:=k2, End:=k2
  13.     Selection.HomeKey Unit:=wdLine, Extend:=wdMove
  14.     Selection.MoveLeft Unit:=wdCharacter, count:=1, Extend:=wdMove
  15.     j2 = Selection.Range.Start
  16.     Selection.SetRange Start:=j1, End:=j2 '重选选中
  17.     Set timurng = Selection.Range
  18.    
  19. End Function
复制代码


评分

1

查看全部评分

TA的精华主题

TA的得分主题

 楼主| 发表于 2024-2-19 08:38 来自手机 | 显示全部楼层
本帖最后由 hcy1185 于 2024-2-19 09:24 编辑

谢谢!附件已经上传
补充一点:答案提取后,括号内支付宽度保证不变

TA的精华主题

TA的得分主题

 楼主| 发表于 2024-2-19 08:57 | 显示全部楼层
过客fppt 发表于 2024-2-18 09:47
这是我新手期写的,但是只对某些特定格式的文档有用,你可以根据你的文档进行修改对应的子过程,子过程 ...

If 是否重复(1) = 1 Then
            Exit For
End If
子过程或函数未定义?谢谢

TA的精华主题

TA的得分主题

 楼主| 发表于 2024-2-19 09:15 | 显示全部楼层
小花鹿 发表于 2024-2-17 08:33
需要附件                                                                                             ...

小花鹿老师你好!
这两天没进论坛,谢谢!
附件已经上传

TA的精华主题

TA的得分主题

发表于 2024-2-19 09:53 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
hcy1185 发表于 2024-2-19 08:57
If 是否重复(1) = 1 Then
            Exit For
End If

image.png

TA的精华主题

TA的得分主题

发表于 2024-2-19 10:15 | 显示全部楼层

楼主啊,看到你的附件,建议你不要去套用我的代码了,重新写比较好,因为我的代码适用的是这样类型的文档
image.jpg

TA的精华主题

TA的得分主题

发表于 2024-2-19 11:35 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册

删除所有答案的方法
image.jpg


Sub 删除括号内所有答案()
    Call 全部替换("(()([每共]*[分”])())", "【\2】", True)
    Call 全部替换("(*)", "(              )", True)
    Call 全部替换("\( [A-D] \)", "(   )", True)
End Sub


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

本版积分规则

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

GMT+8, 2024-12-25 16:08 , Processed in 0.046482 second(s), 13 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

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

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

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