填空题如何提取答案，并修改为所需格式

文人慕

说明：黑色文字为需要修改的内容，红色文字是修改后的内容，蓝色文字是修改的部分。
要求：
（1）填空题中横线上方的文字直接换成横线；（2）增加字段【答案】，其中答案若是只包含一个空，则直接是空的内容即可，若是有多个空，每个空之间用“|”隔开。（提示，【解析】中的故答案为。。。格式一致，都是用分号隔开的，现在需要用竖线隔开）
最好能给个代码，文档比较多，一个一个的替换比较繁琐。谢谢了。

凌空一羽

Sub lkyy()
Dim doc As Document, ph As Paragraph, Pstart As Long
Set doc = ActiveDocument
Selection.HomeKey unit:=wdStory
ReDim br(1 To 1000, 1 To 2)
For Each ph In doc.Paragraphs
    If Left(ph.Range, 4) = "【题干】" Then
        Pstart = ph.Range.Start
        n = n + 1: m = 0
        br(n, 1) = n
        s = ""
        For i = 1 To ph.Range.Characters.Count
            If ph.Range.Characters(i) = "　" Then
                m = m + 1
                If m Mod 2 = 0 Then s = s & "|" & doc.Range(k, i + Pstart - 1)
                k = i + Pstart
            End If
        Next i
        br(n, 2) = Mid(s, 2, 999)
    End If
Next ph
doc.Content.Find.Execute "【解析】", , , , , , , , , "【答案】^p【解析】", 2
n = 0
For Each ph In doc.Paragraphs
    If Left(ph.Range, 4) = "【答案】" Then
        n = n + 1
        ph.Range.Characters(Len(ph.Range) - 1).InsertAfter br(n, 2)
    End If
Next
End Sub

凌空一羽

Sub lkyy()
Dim doc As Document, ph As Paragraph, Pstart As Long
Set doc = ActiveDocument
Selection.HomeKey unit:=wdStory
ReDim br(1 To 1000, 1 To 2)
ReDim cr(1 To 1000, 1 To 2)
'读取【题干】里下划线答案
For Each ph In doc.Paragraphs
    If Left(ph.Range, 4) = "【题干】" Then
        Pstart = ph.Range.Start
        n = n + 1: m = 0
        br(n, 1) = n
        s = ""
        For i = 1 To ph.Range.Characters.Count
            If ph.Range.Characters(i) = "　" Then
                m = m + 1
                If m Mod 2 = 0 Then s = s & "|" & doc.Range(k, i + Pstart - 1)  '将答案提取
                If m Mod 2 = 0 Then a = a + 1: cr(a, 1) = k: cr(a, 2) = i + Pstart - 1  '用于去除下划线的字
                k = i + Pstart
            End If
        Next i
        br(n, 2) = Mid(s, 2, 999)
    End If
Next ph
'加一段为【答案】
doc.Content.Find.Execute "【解析】", , , , , , , , , "【答案】^p【解析】", 2
n = 0
'插入每题题干的答案
For Each ph In doc.Paragraphs
    If Left(ph.Range, 4) = "【答案】" Then
        n = n + 1
        ph.Range.Characters(Len(ph.Range) - 1).InsertAfter br(n, 2)
    End If
Next
'删除下划线的字
For i = a To 1 Step -1
    doc.Range(cr(i, 1), cr(i, 2)).Delete
Next
End Sub

文人慕

凌空一羽 发表于 2020-2-18 13:40
Sub lkyy()
Dim doc As Document, ph As Paragraph, Pstart As Long
Set doc = ActiveDocument

谢谢你，2楼方法可行，但是未删除题干中带有的答案；3楼方法有的题目不可行，暂时还没有找到原因。

zmj9151

______________

文人慕

文人慕 发表于 2020-2-18 14:52
谢谢你，2楼方法可行，但是未删除题干中带有的答案；3楼方法有的题目不可行，暂时还没有找到原因。

用2楼的方法遇到一个问题，就是得到的【答案】这一部分，一些上下脚标的位置不对

gbgbxgb

留个脚印，练习下Word的查找定位与字符串的提取。

提取填空题答案并置于下方新段落.rar (32.12 KB, 下载次数: 19)

2020-7-14 05:44 上传

点击文件名下载附件

小花鹿

Sub xiaohualu()
    Dim ar, n&, i&, s As String, myrange As Range
    ReDim ar(1 To 3, 1 To ActiveDocument.Paragraphs.Count)
    With ActiveDocument.Content.Find
        Do While .Execute("^p【题干】")
            n = n + 1
            ar(1, n) = .Parent.Start + 1
        Loop
    End With
    With ActiveDocument.Content.Find
        n = 0
        Do While .Execute("^p【解析】")
            n = n + 1
            ar(2, n) = .Parent.Start
        Loop
    End With
    For i = 1 To n
        s = ""
        Set myrange = ActiveDocument.Range(ar(1, i), ar(2, i))
        With ActiveDocument.Range(ar(1, i), ar(2, i)).Find
            .Font.Underline = wdUnderlineSingle
            Do While .Execute
                If Not .Parent.InRange(ActiveDocument.Range(ar(1, i), ar(2, i))) Then Exit Do
                s = s & "|" & .Parent.Text
                .Parent.Text = String(Len(.Parent.Text), " ")
            Loop
        End With
        ar(3, i) = Mid(Replace(s, "　", ""), 2)
    Next i
    For i = n To 1 Step -1
        ActiveDocument.Range(ar(2, i), ar(2, i)).Text = Chr(13) & "【答案】" & ar(3, i)
    Next i
End Sub

jany1312

会写代码的都是神人