批量调整word文档段落先后顺序，看附件

文人慕

文档内容各部分段落比较乱，按照先后顺序排列，具体的内容看附件。
哪位大侠，能给出高级替换或者VBA解决一下。

文人慕

有没有大神想出来如何解决了？

sqhsqhli

Sub test2()
Dim a, b As String, i As Integer, j As Integer, k As Integer
b = "【题源】,【题型】,【题干】,【答案】,【解析】,【难度】,【考点】"
a = Split(b, ",")
ActiveDocument.Range.Font.Color = wdColorAutomatic
j = 0
k = 0
With ActiveDocument.Content.Find
               .ClearFormatting
                .MatchWildcards = True
                .Forward = True
                .Text = "([【题源】【题型】【题干】【答案】【解析】【难度】【考点】]{4,})"
                Do While .Execute
                j = j + 1 '取得需要调整的个数
                Loop
End With
aaa:
     For i = 0 To UBound(a)
     With ActiveDocument.Content.Find
                .MatchWildcards = True
                .Forward = True
                .Font.Color = wdColorAutomatic
                .Text = a(i) & "(*)([【题源】【题型】【题干】【答案】【解析】【难度】【考点】]{4,})"
                Do While .Execute
                .Parent.End = .Parent.End - 4
                .Parent.Font.Color = wdColorRed
               .Parent.Cut
                ActiveDocument.Range(ActiveDocument.Range.End - 1, ActiveDocument.Range.End).Paste
                 .Parent.Collapse
                 k = k + 1
                Exit Do
                Loop
    End With
            Next
   If k < j - 1 Then GoTo aaa:
                        '完成j-1个调整，剩下最后1个，根据颜色调整完成
                        
    With ActiveDocument.Content.Find
                .MatchWildcards = True
                .Forward = True
                .Font.Color = wdColorAutomatic
                Do While .Execute
                .Parent.Font.Color = wdColorRed
               .Parent.Cut
                ActiveDocument.Range(ActiveDocument.Range.End - 1, ActiveDocument.Range.End).Paste
                 .Parent.Collapse
                Exit Do
                Loop
    End With
   ActiveDocument.Range.Font.Color = wdColorAutomatic
End Sub

sqhsqhli

国庆节快乐