试卷提取答案，回填答案

hcy1185

春节后安全知识培训试卷（计财科）.rar (22 KB, 下载次数: 24)

2024-2-19 08:41 上传

点击文件名下载附件

试卷原题中包含完整答案，如何用VBA代码把原题中的答案提取出来，放在文档最后，按大小题序号排列好，第二段代码把答案填到原题中。试卷包括两行标题，试卷一至五大题，一填空题，二单项选择题，三多项选择题，四判断题，五简答题。一至四题的答案在（）内，内容两端靠近（）的内侧各1个空格，谢谢！

小花鹿

需要附件                                                                                                                    

zhanglei1371

需要提供两个文档，一个原始的，一个手工模拟处理一小部分的。

过客fppt

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

复制代码

hcy1185

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

hcy1185

过客fppt 发表于 2024-2-18 09:47
这是我新手期写的，但是只对某些特定格式的文档有用，你可以根据你的文档进行修改对应的子过程，子过程 ...

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

hcy1185

小花鹿 发表于 2024-2-17 08:33
需要附件                                                                                             ...

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

过客fppt

hcy1185 发表于 2024-2-19 08:57
If 是否重复(1) = 1 Then
            Exit For
End If

过客fppt

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

过客fppt

删除所有答案的方法



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