求完善代码：解析调序，有瑕疵

weiyingde

将“解析”分枝的三项内容，按A、B、C、D的顺序调整。
代码如下：
Sub 要求匹配解析捕获四个()
    Dim mt, mk, oRng As Range, n&, m&, odoc As Document
    Dim str$, tt$, arr() As Range, x%
    Dim rg As Range, dic As Object, k&, ph As Paragraph
   
    Set odoc = ThisDocument
    Set dic = CreateObject("Scripting.Dictionary")
    osr = odoc.Content
    '************************
    str = Replace(osr, Chr(1), "") '替换控件
    Set ph = odoc.Paragraphs(1)
    Set wt = ph.Range.Words(ph.Range.Words.Count) '注意不要-1
    r = wt.End - Len(ph.Range.Text) + (Len(osr) - Len(str))
    '*************************
    str = Replace(str, Chr(7), "") 'osr改str
    With CreateObject("vbscript.regexp")
        .Global = True
        .Ignorecase = False
        .MultiLine = True
        .Pattern = "(^解析[^\r]*)(([A-D](?:(?![A-D\r]).)*){3})\r"
        
        For Each mt In .Execute(str)
            m = mt.FirstIndex + r: n = mt.Length
            Set oRng = odoc.Range(m, m + n - 1)
            ixsr = mt.submatches(0)
            jxlth = Len(ixsr)
            
            .Pattern = "([A-D])([^A-D\r]+)[,，；。;]"
             For Each mtt In .Execute(oRng)
                 'm2 = mtt.FirstIndex + m: n2 = mtt.Length
                 'Set oRng2 = odoc.Range(m2, m2 + n2)
                 isr2 = IIf(InStr(",，；。;", Right(mtt, 1)) > 0, Left(mtt, Len(mtt) - 1), mtt)
                 nbr = WorksheetFunction.Find(Left(mtt, 1), "ABCD")
                 dic(Val(nbr)) = isr2
             Next
             ky = dic.keys
             ky = SortAry(ky)
             For i = LBound(ky) To UBound(ky)
                srth = srth & dic(ky(i)) & IIf(i < UBound(ky), "；", "。")
             Next
             odoc.Range(m + jxlth, m + n - 1) = srth
             dic.RemoveAll
             srth = ""
        Next
    End With
End Sub

Function SortAry(arr As Variant) As Variant
    Dim i As Long
    Dim j As Long
    Dim temp As Variant
   
    ' 对数组进行升序排序
    For i = LBound(arr) To UBound(arr) - 1
        For j = i + 1 To UBound(arr)
            If arr(i) > arr(j) Then
                ' 交换元素
                temp = arr(i)
                arr(i) = arr(j)
                arr(j) = temp
            End If
        Next j
    Next i
   
    ' 返回排序后的数组
    SortAry = arr
End Function
问题：可能锚定位置不准确，导致乱版和字符重复。
D:\1

weiyingde

问题图片如下，请看图

lss001

见下下楼更新附件！

weiyingde

lss001 发表于 2024-8-29 06:00
odoc.Range(m + jxlth, m + n - 1) = srth
....................................................... ...

我也试过，题目比较多的时候，不行。
因为我采用“替换”的思路，如果采用“边选择边移动”的思路，可能失误率要少很多。
改变目标文本的顺序，要个很你的帖子，我曾想借用他的思路和办法，奈何学艺不精，目前还不会变通，大侠若有功夫，看能不能，取其思路和办法，帮我写写代码。
https://club.excelhome.net/thread-1322288-1-1.html
二楼，duquancai的代码。

lss001

weiyingde 发表于 2024-8-29 07:09
我也试过，题目比较多的时候，不行。
因为我采用“替换”的思路，如果采用“边选择边移动”的思路，可能 ...

见下下楼更新附件！

weiyingde

手机上不好操作，稍后在电脑上试试。

weiyingde

lss001 发表于 2024-8-29 06:00
参考一下附件

程序出问题，没有成功，初始一看，比duquancai大侠的还复杂，我可能一时半会还悟不出来，有功夫在针对我的代码，稍作修改，不用“覆盖式”，采用对字符串区域“移动”的方式实现，可能不会出现这种情况。

weiyingde

我个人觉得，“覆盖”破坏了源文档的结构，造成后续定位的不准，以致再覆盖时“盖”错了位置，改错了地方。
我觉得有两种方式或许能避免：
1、倒叙式改动，从后往前调整。
2、采用duquancai大侠的方式。

lss001

weiyingde 发表于 2024-8-29 12:44
程序出问题，没有成功，初始一看，比duquancai大侠的还复杂，我可能一时半会还悟不出来，有功夫在针对我 ...

测试见下下楼

lss001

weiyingde 发表于 2024-8-29 12:54
我个人觉得，“覆盖”破坏了源文档的结构，造成后续定位的不准，以致再覆盖时“盖”错了位置，改错了地方。 ...

看了下链接，
链接中文本并未有带控件或者表之类。