选枝随机重排：思路闭塞、混乱，求开塞。

weiyingde

下面的程序是对杜大侠的代码进行模仿改造，由于学艺不精，无以延续，求大侠开塞。
1、感觉思路不通。因为要修改原文内容，这会不会是Excel删除一样，必须是倒序？
我对word查找的机理不是很熟悉，私下以为：顺序修改，每改动一次，会对原先查找到的range地址产生影响，造成定位不准……
不知是也不是……
2、程序没有达到预期效果，或根本不是要的结果。
………………
若是duquancai杜大侠或sylun大侠亲临指教，则喜出望外。
期盼高人路过，翘首有缘人搭手。

Sub 选枝随机重排()
Dim mt, mk, oRng As Range, n&, m&, str$
Dim rg As Range, arr(), x%, d As Object, k&, a
Set dic = CreateObject("Scripting.Dictionary")
Set RegE = CreateObject("vbscript.regexp")
RegE.Pattern = "[\(（][A-Z]{1,}[\)）](?:\r)"
istr = Replace(ActiveDocument.Content, Chr(7), "")
    With CreateObject("vbscript.regexp")
        .Global = True: .IgnoreCase = False: .MultiLine = True
        .Pattern = "^\d+[\.．、][^\r]*[\(（]([A-Z])[\)）]\r(([A-Z][\.．、][^\r]*\r)*)(【解析】[^\r]+)"
       For Each mt In .Execute(istr)
            fst0 = mt.firstindex
            lth0 = mt.Length
            Set rng0 = ActiveDocument.Range(fst0, fst0 + lth0)
            
            '原想获取答案填写出的地址，但后面无法对打乱选枝后的答案重新进行操作，所以注释了。
            'For Each mt1 In RegE.Execute(mt)
            '    fst1 = mt1.firstindex
            '    lth1 = mt1.Length
            '    Set rng1 = ActiveDocument.Range(fst1, fst1 + lth1)
            'Next
            sr1 = mt.submatches(0)
            .Pattern = "([A-Z])[\.．、]((?:(?!([A-Z][\.．、])).)*)"
      
            For Each mk In .Execute(rng0.Text)
                fst2 = mk.firstindex
                lth2 = mk.Length
                Set rng2 = ActiveDocument.Range(fst2 + 2, fst2 + 2 + lth2)
                k = k + 1: Set dic(k) = rng2
               
                '以下是对答案选枝进行标注，以便在更新选址之后，再更新答案。
                '但不知如何更新。
                sr2 = mk.submatches(0)
                sr3 = IIf(sr1 = sr2, "√", "")
                sr4 = mk.submatches(1) & sr2
                x = x + 1: ReDim Preserve arr(1 To x): arr(x) = sr4

            Next
               ar = Rndcq(arr, x)
               For i = 0 To dic.Count - 1
                   dic.Items()(i).Text = ar(i + 1)
               Next
               x = 0: k = 0: dic.RemoveAll
        Next
    End With
End Sub
Function Rndcq(arr, r As Integer)
    Dim arr1(), arr2%(), sr%, x%, y%, num%, k%
    k = UBound(arr)
    ReDim arr2(1 To k): ReDim arr1(1 To r)
    For y = 1 To k
        arr2(y) = y
    Next
    Randomize
    For x = 1 To r
        num = (Rnd() * ((k - x + 1) - 1) + 1) \ 1
        arr1(x) = arr(arr2(num))
        sr = arr2(num)
        arr2(num) = arr2(k - x + 1)
        arr2(k - x + 1) = sr
    Next x
    Rndcq = arr1
End Function

weiyingde

自我解决第一个问题。

ming0018

我有一个思路：在每段的段前插入一个随机数字（作为排序的序号），然后再对段落排序。

ming0018

比如：文档有10段，先生成10个随便数，并插入到各段的段首，
然后用ActiveDocument.Content.Sort SortOrder:=wdSortOrderAscending
排序后，再把之前插入的序号删除。

cuanju

ming0018 发表于 2020-4-10 15:23
比如：文档有10段，先生成10个随便数，并插入到各段的段首，
然后用ActiveDocument.Content.Sort SortOrde ...

对正文排序，学习了

thunor

什么意思哦，本想看看这个内容，下载时WINDOWS竟然报发现病毒。

weiyingde

ming0018 发表于 2020-4-10 15:23
比如：文档有10段，先生成10个随便数，并插入到各段的段首，
然后用ActiveDocument.Content.Sort SortOrde ...

谢谢提醒，我在duquancai大侠的代码的启发下，已经解决。
实现了：
1、随机选枝。（A、B、C、D等选枝项随机排版）
2、排序后仍将正确答案在答案处进行了更新。
下一步要实现的是在“解析”中A-D的提示序号进行相应调整。
但这个目前还没有思路。

wdpfox

期待分享代码，学习一下。

                                        莫愁前路无知己，天下谁人不识君！只道是：海内存知己，天涯若比邻！