提取填空题答案无果

weiyingde

duquancai 发表于 2020-3-29 17:17
提取的答案是要与题号 一一对应的，不是重新编序号而是要引用原题号。

若是有两级题号又该如何提取？
杜老师若有功夫，请移步40楼指教。

weiyingde

lss001 发表于 2020-3-29 16:00
Sub 题号提取精简版()
    For Each g In ActiveDocument.Paragraphs
        i = i + 1: j = 0: k = 1:  ...

若是有两级题号又该如何提取？
lss001大侠方便的话，请移步40楼赐教。

weiyingde

lss001 发表于 2020-3-29 16:00
Sub 题号提取精简版()
    For Each g In ActiveDocument.Paragraphs
        i = i + 1: j = 0: k = 1:  ...

发觉大侠的代码通用性比较强，可以提出两级题号，比如40楼，但是感觉还有瑕疵。
长江填空题集锦  
1．①青春期身体外形的变化  内部器官的变化  性机能的成熟  ②青春期充沛的精力  敏捷的思维  强烈渴望  ③青春期在美  内在美  2.遗传  营养  锻炼  3.①男生与生俱来  平静而欣然地接受  ②男生优势  完善自己  4.自强  相信自己  勇敢尝试  不断进步  5.①① 底线意识  触碰道德底线  违反法律  ②““虽不能至，心向往之”  向往美好  永不言弃  6. 战胜自己  超越自己  进取的精神  不懈的坚持  7．修身  “止于至善”  8．①人喜  怒  哀  乐  焦虑  ②我们多方面  ③．观念  行动  9．适度  持续  10．改变认知评价  转移注意  合理宣泄  放松训练  

5题有两个小题号①，显然是多出一个。

lss001

weiyingde 发表于 2020-3-30 14:58
发觉大侠的代码通用性比较强，可以提出两级题号，比如40楼，但是感觉还有瑕疵。
长江填空题集锦  
1． ...

Sub 多级题号提取精简版()
    For Each g In ActiveDocument.Paragraphs
        i = i + 1: j = 0: k = 1: s = ""
        For Each h In g.Range.Words
            j = j + 1
            If i = 1 Then
                s = s & h.Text
            Else
                If j < 3 Then
                    If IsNumeric(Left(h.Text, 1)) Or r = 1 Then
                        If j = 1 Then r = 1 Else r = 0
                        s = s & h.Text
                    Else
                        If j < 2 Then s = s & h.Text
                    End If
                Else
                    If h.Font.Underline = 11 Then
                        s = s & h: k = 0
                    Else
                        k = k + 1: If k = 1 Then s = s & "  "
                    End If
                End If
            End If
        Next
        t = t & s
    Next
    Documents.Add.Content.Text = t
End Sub

weiyingde

lss001 发表于 2020-3-30 18:19
Sub 多级题号提取精简版()
    For Each g In ActiveDocument.Paragraphs
        i = i + 1: j = 0: k ...

品读你的代码，是通过循环段落，再取出每个段落的第一个词（数字），然后查找波浪线的内容，他们组接在一起。对这类题型又用。所以最简单，这样说来，比较巧妙，省略了一些查找的步骤。只是判断多一些，逻辑稍复杂。比较好理解。
谢谢你。

weiyingde

lss001 发表于 2020-3-30 18:19
Sub 多级题号提取精简版()
    For Each g In ActiveDocument.Paragraphs
        i = i + 1: j = 0: k ...

经测试，解决5题小号重复问题，美中不足的是，还有瑕疵，请看：
1．①青春期身体外形的变化  内部器官的变化  性机能的成熟  ②青春期充沛的精力  敏捷的思维  强烈渴望  ③青春期在美  内在美  2.遗传  营养  锻炼  3.①男生与生俱来  平静而欣然地接受  ②男生优势  完善自己  4.自强  相信自己  勇敢尝试  不断进步  5.①底线意识  触碰道德底线  违反法律  ②““虽不能至，心向往之”  向往美好  永不言弃  6战胜自己  超越自己  进取的精神  不懈的坚持  7．修身  “止于至善”  8．①人喜  怒  哀  乐  焦虑  ②我们多方面  ③．观念  行动  9．适度  持续  10．改变认知评价  转移注意  合理宣泄  放松训练
红色部分，引号重复。

lss001

weiyingde 发表于 2020-3-30 19:03
经测试，解决5题小号重复问题，美中不足的是，还有瑕疵，请看：
1．①青春期身体外形的变化  内部器官的 ...

参考楼上。。。。。。。。。。。

sylun

weiyingde 发表于 2020-3-30 14:41
非常好用，大侠技术精熟，思路多，方法多样，学习了。
但是如果有答下题目又该怎样提取呢？
见附件。

要这种效果吗？

1. Sub test3()
   
2.     Dim otext As String
   
3.     Dim info As String
   
4.     Dim regEx As Object
   
5.     Dim aMatch As Object
   
6.    
   
7.     Application.ScreenUpdating = False
   
8.     With ActiveDocument.Content.Find '用特殊字符对下划线内容进行临时标记
   
9.         .Font.Underline = wdUnderlineWavy
   
10.         .Execute replacewith:="##^&##", Replace:=wdReplaceAll
    
11.     End With
    
12.    
    
13.     Set regEx = CreateObject("VBScript.Regexp")
    
14.     With regEx
    
15.         .Global = True
    
16.         .MultiLine = True
    
17.         .Pattern = "^(\d+)([.．][^\r]*?##)"
    
18.         otext = .Replace(ActiveDocument.Content.Text, "##$1.##$2")
    
19.         ActiveDocument.Undo
    
20.         .Pattern = "^([①-⑩])([^\r]*?##)"
    
21.         otext = .Replace(otext, "##$1##$2")
    
22.         .Pattern = "^(\d+)([.．][^\r]+\r##[①-⑩])"
    
23.         otext = .Replace(otext, "##$1.##$2")
    
24.         .Pattern = "##(.+?)##"
    
25.         For Each aMatch In .Execute(otext)
    
26.             info = info & aMatch.Submatches(0) & Space(2)
    
27.         Next
    
28.         .Pattern = "(\d+\.|[①-⑩])  "
    
29.         info = .Replace(info, "$1")
    
30.     End With
    
31.    
    
32.     Documents.Add.Content.Text = Trim(info)
    
33.     Application.ScreenUpdating = True
    
34. End Sub

复制代码

weiyingde

先谢谢，再测试，感觉精妙，应该能技到难纾。好好地学习一下。