提取填空题答案无果

weiyingde

长江填空题集锦
1.青春期的身体变化主要表现在三个方面:身体外形的变化、内部器官的变化和性机能的成熟。【72长江.1.1.1】
2.青春期的我们拥有充沛的精力、敏捷的思维，对成长充满强烈渴望，感觉生活拥有无限可能。【72长江.1.1.1】
3.受遗传、营养和锻炼等因素的影响，我

要求效果为：1. 身体外形的变化  内部器官的变化  性机能的成熟  2. 充沛的精力敏捷的思维 强烈渴望  3. 遗传 营养 锻炼

附件如下：

413191246se

* 魏老师：我的代码不如您的高级，对付着用吧，未做优化，仅供参考：

1. Sub test?????????_New()
   
2.     Dim i As Paragraph
   
3.     For Each i In ActiveDocument.Paragraphs
   
4.         If i.Range Like "#*" Then
   
5.             i.Range.Characters(InStr(i.Range.Text, ".")).Select
   
6.             Do
   
7. sk:
   
8.                 If Selection.Next = vbCr Then Exit Do
   
9.                 If Selection.Next.Underline = wdUnderlineWavy Then
   
10.                     Selection.MoveEnd
    
11.                 Else
    
12.                     Selection.Next.Delete
    
13.                     Selection.InsertAfter Text:=" "
    
14.                     GoTo sk
    
15.                 End If
    
16.             Loop
    
17.         End If
    
18.     Next
    
19.     With ActiveDocument.Content.Find
    
20.         .Execute "([??.????])([ ??^s^t]{1,})", , , 1, , , , , , "\1", 2
    
21.         .Execute "([ ??^s^t]{1,})(^13)", , , 1, , , , , , "\2", 2
    
22.     End With
    
23.     ActiveDocument.Content.Copy
    
24.     ActiveDocument.Close savechanges:=wdDoNotSaveChanges
    
25.     Documents.Add.Content.Paste
    
26.     ActiveDocument.Characters(1).Copy
    
27.     MsgBox "OK! Not Saved! ?????δ????!!!!!!!!!!!!!!!!!!!!!", 0 + 16
    
28. End Sub
    

复制代码

weiyingde

413191246se 发表于 2020-3-26 23:26
* 魏老师：我的代码不如您的高级，对付着用吧，未做优化，仅供参考：

谢谢帮助，谢谢回复。
你这个程序的设计思路好像是：对源文档进行删改，留下数字和有波浪线的文字，其他删

除，然后再将留下的部分复制到新建的文档中，对源文档以不保存修改的方式关闭。然后再将新建

文档中的【*】内容删除。
经测试，有几个问题与你商榷：
1、我这儿运行没有效果。
因为你的代码没有对新建文档做保存，无法看到效果，我添加了两行代码，来保存：
pth = ActiveDocument.Path & "\"
ActiveDocument.SaveAs pth & "提取答案.docx"
仍不见文档。
2、你这段代码，可能与我的预期冲突。
(1).诸如“【72长江.1.1.1】”，标志该题身份，意思是：“七下长江作业第一单元第一课第一框题”，你的匹配代码只局限这种形式，其实还有：【72校考.期中】，【72县考.期末】，【72调研.1.1】等等形式。所以，以这种思路来解决问题，可能会有困难。
(2).代码基于selection来获得结果。而这个操作只是我批量处理中的一段小插曲，在我的程序中，要对大量的文本进行提取，并且还要生成“测试版”“答案版”“答案”等三种形式，几十甚至上百个同学不同的文件。大量使用selection恐使本来慢如蜗牛的程序更加负重爬行，所以，要考虑速度。
(3).使用对源文档进行删除留下合适文本的思路，恐与其他流程冲突，因为，关闭原文档，将无法执行其他的操作。
所以，我想能不能在我的思路上下进行修改，以达目的？
目前，我这段程序的问题是：
1、没有结果。
2、分步测试。也有问题。最严重的问题是：程序的效果与我的设计思路背道而驰。
我的设计预期是：遍历文本段落，先提取每道题目的题号，然后提取该题中划线的部分。而程序的结果是，不是遍历段落，而是多次遍历整个文档，这显然不是我要的结果。
为什么不能遍历文段呢？
为什么一点反应也没有呢？

QQ214189912

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

duquancai

表述不清楚，看不懂题意！！！

duquancai

weiyingde 发表于 2020-3-27 10:00
谢谢帮助，谢谢回复。
你这个程序的设计思路好像是：对源文档进行删改，留下数字和有波浪线的文字，其他 ...

请问：是不是这个意思？

请看楼下代码！

duquancai

weiyingde 发表于 2020-3-27 10:00
谢谢帮助，谢谢回复。
你这个程序的设计思路好像是：对源文档进行删改，留下数字和有波浪线的文字，其他 ...

请问：是不是如下代码的意思？

Sub 提取划线内容2()
    Dim myDoc As Document, myStr As String, myParRange As Range
    Set myDoc = ActiveDocument
    With myDoc.Content.Find
        Do While .Execute("[0-9]@.", , , -1)
            With .Parent
                If isStartNum(.Paragraphs(1).Range.Text) Then
                    myStr = myStr + .Text
                    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 + "  " + .Text
                            End With
                        Loop
                        myStr = myStr + vbCr
                    End With
                    .Start = .Paragraphs(1).Range.End
                Else
                    .Start = .Paragraphs(1).Range.End
                End If
            End With
        Loop
    End With
    MsgBox myStr
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

weiyingde

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

谢谢赐教，谢谢帮助，只是你这个是图片，无法测试效果。
请问大侠能否赐给代码，让我学习学习一下。先谢了。

weiyingde

duquancai 发表于 2020-3-27 22:40
请问：是不是如下代码的意思？

Sub 提取划线内容2()

谢谢杜大侠，谢谢杜老师。
第一重谢谢：谢谢你的多次帮助。每一次都是在望穿秋水之时，你及时援手，雪中送炭，解救燃眉之急。谢谢你了！
第二重感谢：我是一个“Word VBA”盲，是在你的启发和指教下，慢慢懂得一点，逐渐写出一些稚嫩的代码，这些代码虽然条理不清、啰嗦冗杂、漏洞百出，但毕竟还是“启蒙”了。你是我的启蒙老师，谢谢你。在你的一次次的指教下，我才领略到Word VB的奥妙所在。使我这个“老顽童”沉迷在Word VBA的智慧和精妙之中。作为我的启蒙老师，我非常感谢你！
第三重谢谢：感谢你让我知道什么叫做人上有人，天外有天。就愚生徜徉Excel-Home论坛的经历，我知道这个Word VBA板块中你和守柔老师都是大咖，是一对交相辉映的Word VBA双星，每次你的出手，都会引来我们这些愚笨学生的围观、欣赏、观摩……感谢你给这个板块带来了生机，带来了精彩……
盼望你多次的指教，盼望经常巡查这块有你精彩的园地……

sylun

也可以试试如下提取方法。楼主原代码无果的主要原因是查找范围（一个段落）与查找代码（跨段落）不匹配。至于纯格式查找与使用通配符查找及查找区域的改变等是其他潜在因素

1. Sub test()
   
2.     Dim info() As String
   
3.     Dim i As Integer
   
4.     Dim n1 As Integer
   
5.     Dim n2 As Integer
   
6.    
   
7.     With ActiveDocument.Content.Find
   
8.          .Font.Underline = wdUnderlineWavy
   
9.          Do While .Execute
   
10.             With .Parent
    
11.                 n1 = Val(.Paragraphs(1).Range.Text)
    
12.                 If n1 > 0 Then '只针对以阿拉伯数字开头的段落
    
13.                     If n1 <> n2 Then '假设相邻两题的题编号不一样
    
14.                         i = i + 1
    
15.                         ReDim Preserve info(i)
    
16.                         info(i) = n1 & vbTab & .Text
    
17.                         n2 = n1
    
18.                     Else
    
19.                         info(i) = info(i) & Space(2) & .Text
    
20.                     End If
    
21.                 End If
    
22.             End With
    
23.          Loop
    
24.     End With
    
25.     info(0) = "题号" & vbTab & "内容"
    
26.    Documents.Add.Content.Text = Join(info, vbCrLf)
    
27. End Sub

复制代码