提取填空题答案无果

weiyingde

我昨天发帖上的附件，怎么现在还没有？

weiyingde

duquancai 发表于 2020-3-28 20:34
题号是重复的？你把附件传上来，最终要达到什么目的？

昨天上的附件，不知哪儿去了，只有再上一次，杜老师有功夫看一下。

duquancai

weiyingde 发表于 2020-3-29 10:31
昨天上的附件，不知哪儿去了，只有再上一次，杜老师有功夫看一下。

Sub 提取划线内容()
    Dim myDoc As Document, myStr As String, m&
    Dim myParRange As Range, n&, resData()
    Set myDoc = ActiveDocument
    With myDoc.Content.Find
        Do While .Execute("[0-9]@[.．]", , , -1)
            With .Parent
                If isStartNum(.Paragraphs(1).Range.Text) Then
                    Set myParRange = .Paragraphs(1).Range.Duplicate
                    With .Paragraphs(1).Range.Find
                        .Font.Underline = wdUnderlineWavy
                        Do While .Execute
                            With .Parent
                                If Not .InRange(myParRange) Then Exit Do
                                myStr = myStr + vbTab + .Text: n = n + 1
                            End With
                        Loop
                    End With
                    If n > 0 Then
                        m = m + 1: ReDim Preserve resData(1 To m): n = 0
                        resData(m) = .Text + Mid(myStr, 2): myStr = Empty
                    End If
                    .Start = .Paragraphs(1).Range.End
                Else
                    .Start = .Paragraphs(1).Range.End
                End If
            End With
        Loop
    End With
    Documents.Add.Content.Text = Join(resData, vbCr)
End Sub
Function isStartNum(ByVal myStr As String) As Boolean
    Dim re As Object
    Set re = CreateObject("VBScript.Regexp")
    re.Pattern = "^[0-9]+[.．]"
    isStartNum = re.test(myStr)
End Function

lss001

.............................................

weiyingde

duquancai 发表于 2020-3-29 13:34
Sub 提取划线内容()
    Dim myDoc As Document, myStr As String, m&
    Dim myParRange As Range, n ...

谢谢你，已经完美解决了问题，这是第二个好方案，收集了，学习揣摩。

weiyingde

lss001 发表于 2020-3-29 16:00
Sub 提取()
    Set wDoc = ActiveDocument
    With wDoc.Content.Find

简洁好用，完全符合心意，多谢了，收集学习了。

sylun

我之前的代码中val函数对文本是按四舍五入转换的，如果题目正文首字符是较大的数字，获得的题号会不一样，可套用int函数取整处理。
如果用正则处理也可以，只是正则无法识别字符格式，可以考虑对下划线内容作临时标记，只是对处理效率有影响。可试试如下代码，不知对大文档处理效率如何。

1. Sub test2()
   
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.         .Pattern = "##(.+?)##"
    
20.         For Each aMatch In .Execute(otext) '依次提取各标记项文本
    
21.             info = info & aMatch.Submatches(0) & Space(2)
    
22.         Next
    
23.         .Pattern = "(\d+\.)  "
    
24.         info = .Replace(info, "$1")
    
25.     End With
    
26.    
    
27.     ActiveDocument.Undo '撤销临时标记
    
28.     Documents.Add.Content.Text = Trim(info)
    
29.     Application.ScreenUpdating = True
    
30. End Sub

复制代码

duquancai

weiyingde 发表于 2020-3-29 16:45
简洁好用，完全符合心意，多谢了，收集学习了。

提取的答案是要与题号 一一对应的，不是重新编序号而是要引用原题号。

weiyingde

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

是的，杜老师说的不错。

weiyingde

sylun 发表于 2020-3-29 17:00
我之前的代码中val函数对文本是按四舍五入转换的，如果题目正文首字符是较大的数字，获得的题号会不一样， ...

非常好用，大侠技术精熟，思路多，方法多样，学习了。
但是如果有答下题目又该怎样提取呢？
见附件。