代码运行障碍：原文原地（或文后）带格式按序重排段落

weiyingde

说明：由于word VBA语法和基本知识匮乏，思路呆板，故出此毛病。恳请大侠指点。
目的：想将原文以段落开头的数字为序分别在原地、文后重排。
故障：1、原地重排，不能运行；
          2、文后重排，带病运行，数据不全。
代码如下：
Sub 原地带格排段()
Dim m, d, Mdoc As Document, k(), oRng As Range
sr = Replace(ThisDocument.Content, Chr(7), "")
Set sr = ActiveDocument.Content
Set d = CreateObject("scripting.dictionary")
With CreateObject("vbscript.regexp")
     .Global = True
     .IgnoreCase = False
     .MultiLine = True
     .Pattern = "^[\xa0\u3000\s]*(\d+)[^\r]+[\r]" '包含回车符；"^[\xa0\u3000\s]*(\d+)[^\r]+"，不包含回车符。
         For Each m In .Execute(sr)
         Set d(m.SubMatches(0)) = ActiveDocument.Range(m.FirstIndex, m.FirstIndex + m.Length)
         Next
         k = d.keys: WordBasic.SortArray k()
         ActiveDocument.Content = "" ’文后重排将这一句删去，也出问题。
         Selection.EndKey wdStory
         Selection.InsertAfter Chr$(13)
         Selection.InsertAfter Chr$(13)
         For i = 0 To d.Count - 1
            With ActiveDocument.Content
                .Collapse 0
                .FormattedText = d(CStr(k(i))).FormattedText
            End With
         Next
End With
End Sub

小花鹿

效果内容和原文不一样啊，什么情况？

weiyingde

小花鹿 发表于 2017-5-26 13:48
效果内容和原文不一样啊，什么情况？

小花鹿 ，有个附件，你帮我看看，运行一下，会弹出问题对话框。
麻烦你费心了！

weiyingde

小花鹿 发表于 2017-5-26 13:48
效果内容和原文不一样啊，什么情况？

有时间吗？帮我看看。估计可能是
ActiveDocument.Content = "" ’文后重排将这一句删去，也出问题。
         Selection.EndKey wdStory
         Selection.InsertAfter Chr$(13)
         Selection.InsertAfter Chr$(13)
代码的错误。
这几行代码，不知怎样改才使代码正常运行？