试卷提取答案，回填答案

小花鹿

Sub 提取答案()
    Dim s1, n&, doc As Document, reg, ss, s, i&, j&, ST&, ED&
    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
    reg.Pattern = "^[一二三四五六七八九十]{1,}、"
    With doc
        For i = 1 To .Paragraphs.Count
            s = .Paragraphs(i).Range.Text
            If reg.test(s) Then
                s1 = s1 & "|" & i
            End If
        Next i
        s1 = s1 & "|" & .Paragraphs.Count
        s1 = Split(s1, "|")
        reg.Pattern = "^[0-9]{1,}、"
        For i = 1 To UBound(s1) - 2
            ss = ss & Chr(13) & .Paragraphs(s1(i)).Range.Text
            ss = Left(ss, Len(ss) - 1)
            For j = s1(i) + 1 To s1(i + 1) - 1
                With .Paragraphs(j).Range
                    ED = .End
                    If reg.test(.Text) Then
                        .End = .Start
                        .MoveEndUntil "、"
                        .MoveEnd 1
                        ss = ss & Chr(13) & .Text
                        Do
                            ST = .MoveStartUntil("（")
                            .MoveStart 1
                            .MoveEndUntil "）"
                            If ST = 0 Or .End > ED Then Exit Do
                            ss = ss & .Text & "；"
                            .Text = Space(Len(.Text))
                        Loop
                    End If
                End With
            Next j
        Next i
        ss = ss & Chr(13)
        For i = s1(UBound(s1) - 1) To s1(UBound(s1))
            With .Paragraphs(i).Range
                If reg.test(.Text) Then
                    .End = .Start
                    .MoveEndUntil "、"
                    .MoveEnd 1
                End If
                ss = ss & .Text
            End With
        Next i
        For i = s1(UBound(s1)) To s1(UBound(s1) - 1) + 1 Step -1
            s = ""
            With .Paragraphs(i).Range
                If reg.test(.Text) = 0 Then
                    For j = 1 To .ComputeStatistics(1)
                        s = s & Chr(13)
                    Next j
                    .Text = s
                End If
            End With
        Next i
        ss = Chr(13) & Chr(13) & "【提取答案：】" & ss
        reg.Pattern = "；" & Chr(13)
        ss = reg.Replace(ss, Chr(13))
        .Range(.Range.End - 1, .Range.End - 1) = ss
    End With
End Sub

小花鹿

帖代码就审核

hcy1185

小花鹿 发表于 2024-2-24 12:48
帖代码就审核

谢谢老师指导！慢慢学习

hcy1185

小花鹿 发表于 2024-2-24 11:34
Sub 提取答案()
    Dim s1, n&, doc As Document, reg, ss, s, i&, j&, ST&, ED&
    Set reg = CreateO ...

请问小花鹿老师！不隐藏简答题的  “答：”怎么修改代码？谢谢！

小花鹿

hcy1185 发表于 2024-3-2 16:36
请问小花鹿老师！不隐藏简答题的  “答：”怎么修改代码？谢谢！

不明白你的意思                                                                                                            

hcy1185

就是隐藏简答题答案时，不隐藏“答:”，仅隐藏冒号后面的所有文字部分，期待老师指导！

小花鹿

hcy1185 发表于 2024-3-2 20:26
就是隐藏简答题答案时，不隐藏“答:”，仅隐藏冒号后面的所有文字部分，期待老师指导！

我的代码没有隐藏答案，只是把答案部分的空间换成了相同个数的空行                                               
你的要求可以改成下面这样：

'以下将简答题答案删除，并留相应的答题空间
        For i = s1(UBound(s1)) To s1(UBound(s1) - 1) + 1 Step -1
            With .Paragraphs(i).Range
                If reg.test(.Text) = 0 Then
                    .Text = String(.ComputeStatistics(1), Chr(13))
                Else
                    .Start = .End
                    .Text = "答："
                End If
            End With
        Next i

hcy1185

小花鹿 发表于 2024-3-2 22:26
我的代码没有隐藏答案，只是把答案部分的空间换成了相同个数的空行                                     ...

衷心感谢！