试卷提取答案，回填答案

hcy1185 · 发表于 2024-2-16 20:32

本帖最后由 hcy1185 于 2024-2-19 08:44 编辑

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

小花鹿 · 发表于 2024-2-17 08:33

需要附件

zhanglei1371 · 发表于 2024-2-17 15:26

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

过客fppt · 发表于 2024-2-18 09:47

本帖最后由过客fppt 于 2024-2-18 20:10 编辑

Sub 批量调整答案到每道题目末端()
Dim l, j As Long
Dim rng, rng1 As Range
Dim newDoc As Document
Dim isNo1 As Boolean
Dim timustr, daanstr As String
timustr = "试题"
daanstr = "参考答案：^p"
Call 查找(daanstr, 0, 1)
If Selection.Find.Found = False Then
MsgBox "查找不到：" & daanstr
Exit Sub
End If
Call 自动查询题量
Set newDoc = Documents.Add(ActiveDocument.FullName)
Call 查找(daanstr, 0, 1)
j = Selection.Range.Start
Set rng1 = ActiveDocument.Range(j, ActiveDocument.Content.End)
rng1.Select
' Call 全部替换("【分析】*【详解】", "【解答】", True)
Call 全部替换("(^p[0-9]{1,3})([.．、])", "\1.【答案】", True)
rng1.Font.Color = wdColorBlue
rng1.Font.Name = "幼圆"
rng1.Font.Bold = False
Selection.HomeKey Unit:=wdStory, Extend:=wdMove '回到文档的起点
Dim Index As Integer
isNo1 = True
timuCount = timuCount / 2 - 1
For Index = 1 To timuCount
If isNo1 Then
' Call 查找(timustr, 0, 1)
If Selection.Find.Found = False Then
MsgBox "查找不到 " & timustr
Exit Sub
End If
isNo1 = False
End If
Call 识别题干和答案区域并选中(Index)
If Selection.Find.Found = False Then
MsgBox "查找不到第 " & Index & " 题的题干！"
Exit For
End If
l = Selection.Range.End + 1
Call 查找(daanstr, 0, 1)
Call 识别题干和答案区域并选中(Index)
If Selection.Find.Found = False Then
MsgBox "查找不到第 " & Index & " 题的答案！"
Exit For
End If
If 是否重复(1) = 1 Then
Exit For
End If
Set rng = Selection.Range
Selection.SetRange Start:=l, End:=l
Selection.TypeParagraph '回车
ActiveDocument.Range(l, l).FormattedText = rng '.FormattedText
Selection.SetRange Start:=l, End:=l
rng.Delete
Next Index
Selection.HomeKey Unit:=wdStory, Extend:=wdMove '回到文档的起点
Call 全部替换(daanstr, "", True)
Call 全部替换("^p[0-9]{1,3}[.．、]【答案】", "^p【答案】", 1)
Call 全部替换("解析", "解答", False)
MsgBox "已完成" & Index & " 道题的答案转移到每道题后！"
End Sub

复制代码

这是我新手期写的，但是只对某些特定格式的文档有用，你可以根据你的文档进行修改对应的子过程，子过程如下：

Function 查找(文本, 通配符, 向下)
If Len(文本) <= 1 Then
MsgBox "警告：只查找一个字符，每次只能找到第一个！"
End If
Dim rng As Range
' Set rng = IIf(Len(Selection.Range.text) <= 1, ActiveDocument.Content, Selection.Range)
Selection.Find.ClearFormatting
With Selection.Find
.text = 文本
.Forward = 向下
.Wrap = wdFindContinue '往复查找
.MatchWildcards = 通配符
End With
Selection.Find.Execute
Selection.Find.Parent.Select
' Set rng = Nothing
End Function

复制代码

Function 自动查询题量()
'
' Macro1 Macro
' 宏由 ZPL 录制，时间: 2022/11/19
'
Dim j As Long '记录第一个题号光标位置
Dim k As Long '记录第最后一个题号光标位置
'Public timuCount As Integer '记录总题量（全局变量要在函数外定义）
Dim i As Integer
Do
If i <= 0 Then
Call 查找("^p[0-9]{1,3}[.．、]", True, True)
j = Selection.Range.Start + 4
i = i + 1
Else
Call 查找("^p[0-9]{1,3}[.．、]", True, True)
k = Selection.Range.Start + 4
i = i + 1
End If
Loop Until j = k
timuCount = i - 1
自动查询题量 = timuCount
End Function

复制代码

Function 全部替换(原文字, 替换为, 通配符)
' 宏由 ZPL 录制，时间: 2022/12/07
Dim rng As Range
Set rng = IIf(Len(Selection.Range.text) <= 1, ActiveDocument.Content, Selection.Range)
rng.Find.ClearFormatting
With rng.Find
.text = 原文字
.Forward = True
.Wrap = wdFindStop 'Wrap = wdFindAsk(找到会弹出提示框)'Wrap = wdFindStop(完成替换会停止)
.MatchCase = False 'True 指定要查找的文本应区分大小写。
.MatchByte = False '搜索期间区分全角和半角字母或字符，则此属性返回 True ;否则返回 False 。将属性值设置为 True 或 False 以启用或禁用该功能。
.MatchWildcards = 通配符 '通配符开关
.MatchWholeWord = False '真要查找只整个单词，全字匹配。
.MatchFuzzy = False '确定 Microsoft Word 在搜索过程中是否对日语文本使用非特定搜索选项
.Replacement.text = 替换为
End With
rng.Find.Execute Replace:=wdReplaceAll
全部替换 = rng.Find.Found
rng.Find.ClearFormatting
End Function

复制代码

Function 识别题干和答案区域并选中(index1 As Integer)
Dim k1, k2, j1, j2 As Long
Dim timurng, daanrng As Range
Dim b As Integer
Call 查找("^p" & index1 & "[.．、]*^p" & index1 + 1 & "[.．、]", True, 1)
识别题干和答案区域并选中 = Selection.Find.Found
k1 = Selection.Range.Start
k2 = Selection.Range.End
j1 = k1 + 1
Selection.SetRange Start:=k2, End:=k2
Selection.HomeKey Unit:=wdLine, Extend:=wdMove
Selection.MoveLeft Unit:=wdCharacter, count:=1, Extend:=wdMove
j2 = Selection.Range.Start
Selection.SetRange Start:=j1, End:=j2 '重选选中
Set timurng = Selection.Range
End Function

复制代码

hcy1185 · 发表于 2024-2-19 08:38

本帖最后由 hcy1185 于 2024-2-19 09:24 编辑

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

hcy1185 · 发表于 2024-2-19 08:57

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

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

hcy1185 · 发表于 2024-2-19 09:15

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

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

过客fppt · 发表于 2024-2-19 09:53

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

过客fppt · 发表于 2024-2-19 10:15

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

过客fppt · 发表于 2024-2-19 11:35

删除所有答案的方法

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

		自动登录	找回密码
密码			免费注册

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

评分