按要求分类删除资料的代码，能否完善，避免反复运行？

weiyingde

代码目的：从综合资料中按要求分类删除（或保留）指定类型的资料，其类型如：
               1．选出下列词语中加点字读音全对的一项[16黄冈]（D）                  A．祈祷(dǎo)     恻隐(cè)    倒坍(tā)         龙吟凤哕(huì)

             B．嗔怪(chēn)    涟漪(qǐ)     遒劲(qiú)        忍俊不禁(jīn)

             C．阔绰(chò)     伶仃(líng)    逶迤(yí)         鳞次栉比(jié)

             D．真谛(dì)       炽热(chì)    酝酿(niàng)      惟妙惟肖(xiào)

         【解析】A. 坍(tān)B. 漪(yī)C. 绰(chuò)栉(zhì)

              2.下面各句中标点符号使用合乎，规范的一项是[15黄冈](B)

         A．风来了，荷叶为什么就不能迎风招展？谁规定了它的下场非得是宁折不弯？风让它欢欣、雨也让它喜悦，荷盘中的一汪水，被荷叶摇成一颗亮晶晶的玉珠。

         B．在育才中学举行的“5·12”防震疏散演练中，九(2)班落实任务最好的是三、四组。

        C．罗丹用石头雕塑了一只鹰，鹰雕塑得栩栩如生，好像真的在天空中展翅高飞一样。有人问他：“你是怎样把石头雕塑得飞起来的？罗丹大师。”

        D．东六宫大都作为古代艺术品的陈列专馆，展出宫内收藏的青铜器、绘画、陶瓷……等。

       【解析】A句中的顿号应为逗号, 因为前后句子是短句,不是词组; c句中的问号应该在“罗丹大师”之后,表示整个句子是一个问句；D句“等”前面省略号多余。
               其中“16"指的是2016年的资料，"黄冈”是指"黄冈地区”
               假若我想把综合资料中所有2016年的所有选择题及其解析删除，代码为：
               Sub 分类删除能否一次性搞定()
                     With ActiveDocument.Content.find
                            .Execute "([0-9]@[\.、．]@[!^13]@\[16[!^13]@^13*)([0-9]@[\.、．])", , , 1, , , , , , "\2", 2
                     End Sub
问题：代码可以运行，也有作用，但必须重复多次运行代码，才能达到目的。
要求：能否在云代码的基础上，一次性删除呢？避免多次运行代码带来的麻烦，而且也更好的融入其它程序之中，完成后续任务。
请大侠下载附件：
1、附件中所有蓝色字体的文字都是2016年中考题目，其中红色的“16”即为其中的关键字眼。
2、运行代码，看看怎样修改才能确保一次性删除，盼望能在源代码的基础上达到目的。
谢谢的帮助！！

遗憾;附件代码里，少了一个“find”，若测试，麻烦加上去。

weiyingde

再求大侠，在线专侯，盼望援手，谢谢顶贴！！！

weiyingde

再求大侠，在线专侯，盼望援手，谢谢顶贴！！！

duquancai

weiyingde 发表于 2017-7-20 17:49
再求大侠，在线专侯，盼望援手，谢谢顶贴！！！

Sub shishi()
    Dim myStart&, myDoc As Document, b As Boolean
    Set myDoc = ActiveDocument
    With myDoc.Content.Find
        Do While .Execute("^13[0-9]@[.、．]", , , 1, , , 0)
            With .Parent
                If Not b Then
                    .MoveEndUntil vbCr
                    If InStr(.Text, "[16") Then
                        myDoc.Range(.Start + 1, myDoc.Content.End).Text = Empty
                    End If
                    b = True
                Else
                    .MoveEndUntil vbCr
                    If InStr(.Text, "[16") Then
                        myDoc.Range(.Start + 1, myStart).Text = Empty
                    End If
                End If
                myStart = .Start + 1: .Collapse
            End With
        Loop
    End With
End Sub

weiyingde

duquancai 发表于 2017-7-20 20:13
Sub shishi()
    Dim myStart&, myDoc As Document, b As Boolean
    Set myDoc = ActiveDocument

谢谢杜老师，每有为难都得到杜老师的援救，心存感激；若有时间，希望得到老师的点拨，能够变通运用。

weiyingde

duquancai 发表于 2017-7-20 20:13
Sub shishi()
    Dim myStart&, myDoc As Document, b As Boolean
    Set myDoc = ActiveDocument

杜老师：      源代码能够取到删除的作用，只是要反复运行代码。
      能否在源代码的基础上，进行优化达此目的？
      若能，盼望你的指教。

weiyingde

请教大家，上一楼的目的能达到吗？

weiyingde

路过大侠，援手支招，谢谢了。

weiyingde

duquancai 发表于 2017-7-20 20:13
Sub shishi()
    Dim myStart&, myDoc As Document, b As Boolean
    Set myDoc = ActiveDocument

杜老师，您赐的代码能简化为下面的代码吗？请明示……
Sub shishi()
    Dim myStart&, myDoc As Document, b As Boolean
    Set myDoc = ActiveDocument
    With myDoc.Content.Find
        Do While .Execute("^13[0-9]@[.、．]", , , 1, , , 0)
            With .Parent
                 .MoveEndUntil vbCr
                 If InStr(.Text, "[16") Then
                    myDoc.Range(.Start + 1, myStart).Text = Empty
                 End If
                myStart = .Start + 1: .Collapse
            End With
        Loop
    End With
End Sub

duquancai

weiyingde 发表于 2017-7-21 17:43
杜老师，您赐的代码能简化为下面的代码吗？请明示……
Sub shishi()
    Dim myStart&, myDoc As Docum ...

你是觉得我前面写的代码有问题或者太累赘了？因此你要简化。能不能简化陈目前这样？你完全可以自己测试啊！