试卷提取答案，回填答案

小花鹿

这种问题写代码太麻烦了                                                                                       

batmanbbs

PS：并没有真正删除答案，只是将字体颜色设置成白色，所以就没有写回填答案

小花鹿

练习一下，只写了提取填空题答案：
Sub 提取答案()
    Dim reg, t, p As Paragraph, pn&, i&
    With ActiveDocument
        pn = .Paragraphs.Count
        For i = 4 To 15 '提取填空题答案
            With .Paragraphs(i).Range.Find
                .Execute "[\)）]*[\(（]", , , 1, , , , 0, , "；", 2
                .Execute "([0-9]{1,}、)*[\(（]", , , 1, , , , 0, , "\1", 2
                .Execute "[\(）]*(^13)", , , 1, , , , 0, , "\1", 2
            End With
        Next i
    End With
End Sub

小花鹿

Sub test1()
    Dim s1, s2, n&, doc As Document, reg, ss, s, i&, j&, mh
    Set reg = CreateObject("vbscript.regexp")
    reg.Global = True
    Set doc = ActiveDocument
    With ActiveDocument.Content.Find
        .Execute "\(", , , 1, , , , 0, , "（", 2
        .Execute "\)", , , 1, , , , 0, , "）", 2
    End With
    '以下取得各大题起始位置
    With doc.Range.Find
        .Text = "^13[一二三四五六七八九十]{1,}、"
        .MatchWildcards = True
        Do While .Execute
            n = doc.Range(0, .Parent.End).Paragraphs.Count
            s1 = s1 & "|" & n
            s2 = s2 & "|" & (.Parent.Start + 1)
        Loop
        s1 = s1 & "|" & doc.Paragraphs.Count
        s2 = s2 & "|" & doc.Range.End
    End With
    s1 = Split(s1, "|")
    s2 = Split(s2, "|")
    '以下提取填空、选择、判断题答案
    For j = 1 To UBound(s1) - 2
        ss = ss & Chr(13) & doc.Paragraphs(s1(j)).Range.Text
        ss = Left(ss, Len(ss) - 1)
        For i = s1(j) + 1 To s1(j + 1) - 1
            s = doc.Paragraphs(i).Range.Text
            reg.Pattern = "^[0-9]{1,}、"
            If reg.test(s) Then
                Set mh = reg.Execute(s)
                ss = ss & Chr(13) & mh(0)
                reg.Pattern = "[\(（].*?[）\)]"
                If reg.test(s) Then
                    Set mh = reg.Execute(s)
                    For Each s In mh
                        ss = ss & s
                    Next s
                End If
            End If
        Next i
    Next j
    '以下提取简答题答案
    s = doc.Range(s2(UBound(s2) - 1), s2(UBound(s2))).Text
    reg.Pattern = "([0-9]{1,}、).*?(答：)"
    s = reg.Replace(s, "$1$2")
    ss = ss & Chr(13) & s
    ss = "提取答案：" & ss
    With Selection
        .EndKey 6
        .Text = ss
    End With
End Sub

hcy1185

batmanbbs 发表于 2024-2-19 18:15
PS：并没有真正删除答案，只是将字体颜色设置成白色，所以就没有写回填答案

谢谢!请发个附件吧

hcy1185

小花鹿 发表于 2024-2-22 11:55
Sub test1()
    Dim s1, s2, n&, doc As Document, reg, ss, s, i&, j&, mh
    Set reg = CreateObject ...

小花鹿老师!谢谢帮助!!!
能把原题的答案删除吗?保留原字符宽度,谢谢!!!!

hcy1185

小花鹿 发表于 2024-2-22 11:55
Sub test1()
    Dim s1, s2, n&, doc As Document, reg, ss, s, i&, j&, mh
    Set reg = CreateObject ...

如果已经运行过提取答案,就退出代码,怎么加一句?不好意思,不懂Word的vba,Excelvba会一点,谢谢!

小花鹿

常扬帆

我在本论坛收集收藏的关于“提取类”的内容有22个，楼主看有用没？

batmanbbs

hcy1185 发表于 2024-2-22 15:35
谢谢!请发个附件吧

EH现在审核太慢