提取填空题答案无果

weiyingde

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

好的，我上附件里。

weiyingde

帖子要审核，很麻烦，有劳大侠了……

weiyingde

其实，若是不考虑题号，非常简单。
Sub 无题号提取()
With ActiveDocument.Content.Find
     .Font.Underline = wdUnderlineWavy
    Do While .Execute = True
       istr = istr & .Parent & Space(2)
    Loop
End With
Documents.Add.Content.Text = istr
End Sub

duquancai

weiyingde 发表于 2020-3-28 20:52
其实，若是不考虑题号，非常简单。
Sub 无题号提取()
With ActiveDocument.Content.Find

就是啊，只是多一些判断，多一些循环 嘛！

weiyingde

主要就是折腾在题号上。也正是这暴露了我半路出家的缺陷，稍一变通，就捉襟见肘，疲于奔命，穷于应付。所以反复麻烦大虾。

QQ214189912

weiyingde 发表于 2020-3-28 18:27
你的代码我整理出来了，测试没有效果，你看看是不是？
Sub test2()
Dim rng As Range, myrange As Rang ...

1. Sub test26()
   
2.     Dim rng As Range, myrange As Range, inti As Integer
   
3.     Dim istr01 As String, istr02 As String, istr03 As String
   
4.     Dim dic As Object, myRegExp As Object, mhs As Object
   
5.     Dim ky As Variant, tm As Variant
   
6.     Set dic = CreateObject("scripting.dictionary")
   
7.     Set myRegExp = CreateObject("Vbscript.RegExp")
   
8.     With ActiveDocument
   
9.         For inti = 1 To .Paragraphs.Count
   
10.             Set rng = .Paragraphs(inti).Range
    
11.             Set myrange = .Paragraphs(inti).Range
    
12.             With rng
    
13.                 myRegExp.MultiLine = True
    
14.                 myRegExp.Pattern = "(^\d{1,}\.).*"
    
15.                 If myRegExp.test(.Text) Then
    
16.                     Set mhs = myRegExp.Execute(.Text)
    
17.                     If mhs.Count = 0 Then Exit Sub
    
18.                     istr01 = mhs(0).submatches(0)
    
19.                     With .Find
    
20.                         .ClearFormatting
    
21.                         .Font.Underline = wdUnderlineWavy
    
22.                         Do While .Execute
    
23.                             If Not .Parent.InRange(myrange) Then Exit Do
    
24.                             istr02 = .Parent.Text
    
25.                             If dic.Exists(istr01) Then
    
26.                                 dic(istr01) = dic(istr01) & Space(2) & istr02
    
27.                             Else
    
28.                                 dic(istr01) = istr02
    
29.                             End If
    
30.                         Loop
    
31.                     End With
    
32.                 End If
    
33.             End With
    
34.         Next
    
35.     End With
    
36.     ky = dic.keys
    
37.     tm = dic.items
    
38.     For inti = LBound(ky) To UBound(ky)
    
39.         istr03 = istr03 & ky(inti) & tm(inti) & Chr(13)
    
40.     Next
    
41.     Documents.Add.Content.Text = istr03
    
42. End Sub

复制代码

乐乐2006201505

weiyingde 发表于 2020-3-28 15:47
Val(.Paragraphs(1).Range.Text)
这个太妙了，试了一下。非常非常好用。
比用left要省心，

其实不仅仅是你说的这个妙，更妙的是，利用题号相不相同解决了同一序号合并同类项，不同题号另起锅灶的问题。

weiyingde

QQ214189912 发表于 2020-3-27 21:09
.............

经测试，还是没有效果，不知大侠试过没有。

QQ214189912

weiyingde 发表于 2020-3-29 09:10
经测试，还是没有效果，不知大侠试过没有。

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

weiyingde

真是怪了，我反复试验，就是没有效果。