1234

ExcelHome技术论坛

用户名  找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

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

[分享] 一套试卷的卷后答案分移于对应题号的试题后

[复制链接]

TA的精华主题

TA的得分主题

发表于 2025-1-25 14:06 | 显示全部楼层 |阅读模式
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
这两天没事,闲着,就写了将一套试卷的卷后答案分别移置于对应题号后的代码,供有兴趣的参考使用。
1.试卷后的答案和试题必须用特定分隔符分隔,这在代码中看得出来。
2.试题答案的对应题号比较讲究,必须是“数字”和“.”,这在代码中也看得出来。
如果还有好的代码,欢迎指正。
Sub New卷后答案到题后答案()     '本卷后答案由卷后移至题后代友由四川绵竹中学王泽完成,使用请指明出处。
Dim KeyLabelParagraph As Integer     '即标志性的答案分隔字符“{【参考答案】}”所在行的行数
Dim KeystartP As Integer
Dim KeyendP As Integer
Dim tempInsertP As Integer
Dim InsertP As Integer
Dim KTRange As Range
Dim i As Integer
Dim n As Integer
Dim m As Integer

ActiveWindow.Selection.HomeKey Unit:=wdStory
With ActiveDocument.ActiveWindow.Selection.Find
    .Text = "{【参考答案】}"
End With
ActiveDocument.ActiveWindow.Selection.Find.Execute
If ActiveDocument.ActiveWindow.Selection.Find.Found = False Then
    MsgBox "没有找到标志性的答案分隔字符:" & """" & "{【参考答案】}" & """" & ",请设置后再试。", vbInformation, "注意:"
    Exit Sub
End If
KeyLabelParagraph = ActiveDocument.Range(0, Selection.End).Paragraphs.Count
KeyendP = KeyLabelParagraph
For i = 1 To KeyLabelParagraph - 1
    If IsExist(ActiveDocument.Paragraphs(i).Range.Text, "(^\d{1,2}[.])") Then n = n + 1
Next

For i = KeyLabelParagraph To ActiveDocument.Paragraphs.Count
    If IsExist(ActiveDocument.Paragraphs(i).Range.Text, "(^\d{1,2}[.])") Then m = m + 1
Next
If m <> n Then
    MsgBox "试题数不等于答案数,检查后再执行。", vbInformation, "注意:"
    Exit Sub
End If
ActiveDocument.Application.ScreenUpdating = False
tempInsertP = 0
InsertP = 1
Do
FindKeyStartParagraph:
    If InsertP >= KeyLabelParagraph Then Exit Do
    For i = KeyendP + 1 To ActiveDocument.Paragraphs.Count
        If IsExist(ActiveDocument.Paragraphs(i).Range.Text, "(^\d{1,2}[.])") Then
            KeystartP = ActiveDocument.Range(0, ActiveDocument.Paragraphs(i).Range.End).Paragraphs.Count
            For n = KeystartP + 1 To ActiveDocument.Paragraphs.Count
                If n = ActiveDocument.Paragraphs.Count Then
                    KeyendP = ActiveDocument.Paragraphs.Count - 1
                    GoTo FindKeyEndParagraph
                ElseIf IsExist(ActiveDocument.Paragraphs(i).Range.Text, "(^\d{1,2}[.])") Then
                    KeyendP = n - 1
                    GoTo FindKeyEndParagraph
                End If
            Next
FindKeyEndParagraph:
            If KeystartP = ActiveDocument.Paragraphs.Count Then
                KeyendP = KeystartP
            End If
            Set KTRange = ActiveDocument.Range(ActiveDocument.Paragraphs(KeystartP).Range.Start, ActiveDocument.Paragraphs(KeyendP).Range.End - 1)
            KTRange.Select
            ActiveWindow.Selection.Range.Copy
            Exit For
        End If
    Next
FindPosition:
    For i = InsertP To KeyLabelParagraph - 1
        If IsExist(ActiveDocument.Paragraphs(i).Range.Text, "(^\d{1,2}[.])") Then
            If i = KeyLabelParagraph - 1 Then
                InsertP = i
                Exit For
            End If
            For m = i + 1 To KeyLabelParagraph - 1
                If IsExist(ActiveDocument.Paragraphs(m).Range.Text, "(^\d{1,2}[.])") Then
                    InsertP = m - 1
                    GoTo nextFindPosition
                ElseIf IsExist(ActiveDocument.Paragraphs(m).Range.Text, "^([二三四五]、|第[ⅡⅢⅣ]卷)") Then
                    If tempInsertP = 0 Then tempInsertP = m - 1
                End If
            Next
        ElseIf i = KeyLabelParagraph - 1 Then
            InsertP = i
        End If
    Next
   
nextFindPosition:
If tempInsertP = 0 Then
    ActiveDocument.Range(ActiveDocument.Range.Paragraphs(InsertP).Range.End - 1, ActiveDocument.Range.Paragraphs(InsertP).Range.End - 1).Select
Else
    ActiveDocument.Range(ActiveDocument.Range.Paragraphs(tempInsertP).Range.End - 1, ActiveDocument.Range.Paragraphs(tempInsertP).Range.End - 1).Select
End If
    tempInsertP = 0
    ActiveWindow.Selection.TypeText (vbCrLf & "【答案】:")
    TimeLapse (0.7)           '可根据自己的机器性能对该值进行调整,值越大时间延越长,值越小时间延时越短,时间不合理过短会导致程序出错!
    ActiveWindow.Selection.Range.Paste
    InsertP = InsertP + KTRange.Paragraphs.Count + 1
    KeyLabelParagraph = KeyLabelParagraph + KTRange.Paragraphs.Count
    KeyendP = KeyendP + 1
    If KeyendP = KeyLabelParagraph Then Exit Do
Loop
   
    ActiveWindow.Selection.HomeKey Unit:=wdStory
    With ActiveDocument.ActiveWindow.Selection.Find
            .Text = "^p^p"
            .Replacement.Text = "^p"
            .Execute FindText:="^p^p", ReplaceWith:="^p", Replace:=wdReplaceAll
    End With
    ActiveWindow.Selection.EndKey Unit:=wdStory
    ActiveWindow.Selection.MoveLeft Unit:=wdCharacter, Count:=1
    With ActiveDocument.ActiveWindow.Selection.Find
            .Text = "^p^p"
            .Replacement.Text = "^p"
            .Execute FindText:="^p^p", ReplaceWith:=" ", Replace:=wdReplaceOne
    End With
    With ActiveDocument.Content.Find        '删除“【答案】:”后的数字
        .ClearFormatting
        .Replacement.ClearFormatting
        .MatchWildcards = True
        With .Replacement '替换条件
            .ClearFormatting
        End With
        .Execute FindText:="([【][答][案][】][:])([0-9]{1,2}.)(*)", ReplaceWith:="\1\3", Replace:=wdReplaceAll    '屏蔽上行,答案中对应的题号将会显示出来。
    End With
    ActiveWindow.Selection.HomeKey Unit:=wdStory
    MsgBox "程序执行完成。", vbInformation, "注意:"
    ActiveDocument.Application.ScreenUpdating = True
End Sub
Public Function IsExist(ByVal sText As String, ByVal Regul As String) As Boolean
Dim reg
Set reg = CreateObject("vbscript.regexp")
IsExist = False
With reg
    .Global = True
    .IgnoreCase = False
    .Pattern = Regul                '识别试题题号的关键,根据你的需要可以进行增删
    If .test(sText) Then
        IsExist = True
    End If
End With
End Function
Private Sub TimeLapse(ByVal a As Byte)
    Dim Savetime As Single
    Savetime = Timer '记下开始的时间
    While Timer < Savetime + a '循环等待
    DoEvents '转让控制权,以便让操作系统处理其它的事件
    Wend
End Sub
最后祝大家春节快乐。祝管理员给我发个大红包。

TA的精华主题

TA的得分主题

发表于 2025-1-26 09:42 来自手机 | 显示全部楼层
只一个“移动答案”的任务,需要这么多代码,感觉好复杂!

TA的精华主题

TA的得分主题

 楼主| 发表于 2025-1-26 19:39 | 显示全部楼层
肯定有改进的地方,只是我个人而言目前的代码只能如此了。

TA的精华主题

TA的得分主题

发表于 2025-1-27 22:49 | 显示全部楼层
本帖最后由 fandonglong 于 2025-1-28 09:11 编辑

说下个人思路,愚见哈,不知是否能实现:
1、查找“参考答案”获取其起始位置,利用这个位置标记可分割成题目区和答案区;
2、在题目区通过查找题号获取题号起始位置数组arr,在答案区也类似操作可获取答案起始位置数组brr;
3、比对两数组的最大维数,检查题目数量和答案数量是否一致;
4、利用以上数组创建书签;
5、将每题答案按倒序方式逐一插入题目区。
另:查找位置最好使用find函数,正则可以统计数量,有图片好像不行。

TA的精华主题

TA的得分主题

 楼主| 发表于 2025-1-28 08:56 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
fandonglong 发表于 2025-1-27 22:49
说下个人愚见哈,不知是否能实现:
1、查找“参考答案”获取其起始位置,利用这个位置标记可分割成题目区和 ...

谢谢你的建议。实现方式基本一样,没有根本性的改变。你的建议是用数组来实现,正如你所说,答案数组每次移动答案后,尚未移动的答案行数都会跟着变化 。我的方式是每次使用在原来行的基础上找到新开始行,都不会将更多的时间用在此开消上。另外还写了一段代码,开始是将所有答案移到最开始处,从后到前加每题答案,加完后,将答案移到最后,结束,也行。但些操作多两次复制和粘贴开消。

TA的精华主题

TA的得分主题

 楼主| 发表于 2025-2-1 18:56 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
fandonglong 发表于 2025-1-27 22:49
说下个人思路,愚见哈,不知是否能实现:
1、查找“参考答案”获取其起始位置,利用这个位置标记可分割成题 ...

我尝试了一下不直接用复制和粘贴的操作,效率明显提高。但书签的方式没有试过,谢谢你的建意。
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

1234

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

GMT+8, 2025-2-3 14:03 , Processed in 0.038319 second(s), 10 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

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

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

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