VBA改写VBA代码

Sub df()
Dim pa As Paragraph, re As Object
    ActiveDocument.Range.Find.Execute "_^13", , , 2, , , , 0, 0, "", 2  '第一个2决定是否通配,第二个决定是否全部替换
    Set re = CreateObject("vbscript.regexp")
    re.Global = 1
    For Each pa In ActiveDocument.Paragraphs
        If InStr(pa.Range, ":=") > 0 Then
              re.Pattern = "\w+:=.+?(?=,)|\w+:=.+(?=\))|\w+:=.+?(?=\r)"
            For Each ma In re.Execute(pa.Range)
                s1 = Split(ma, ":=")(0)
                s2 = Split(ma, ":=")(1)

                If ch13 = 0 Then
                    ch13 = ch13 + 1
                    pa.Range.InsertBefore Chr(13)
                End If
ma = Replace(Replace(ma, "(", "\("), ")", "\)")
                ActiveDocument.Range(pa.Range.Previous.End - 1, pa.Range.Previous.End - 1).InsertAfter "virant " & s1 & "=" & s2 & Chr(13)
                If InStr(pa.Range, "(") > 0 Then
                    pa.Range.Find.Execute "\(" & ma, MatchWildcards:=1, replacewith:="(" & s1, Replace:=1
                    pa.Range.Find.Execute "[ \,]{1,}" & ma, MatchWildcards:=1, replacewith:=" " & s1, Replace:=1
                    pa.Range.Find.Execute ma, replacewith:=s1, Replace:=1
                    If UBound(Split(pa.Range, ":=")) = 0 And pa.Range.Characters.Last.Previous <> ")" Then pa.Range.Characters.Last.Previous.InsertAfter ")"
                ElseIf UBound(Split(pa.Range, ":=")) > 1 Then
                    pa.Range.Find.Execute "[ ,]{1,}" & ma, MatchWildcards:=1, replacewith:="(" & s1, Replace:=1
                Else
                    pa.Range.Find.Execute " " & ma, replacewith:="(" & s1 & ")", Replace:=1
                End If
            Next
            ch13 = 0
        End If
        fi = Split(Trim(pa.Range.Text), " ")(0)
        re.Pattern = "\.\w+\r"
        If re.test(pa.Range) And InStr(pa.Range, "With") = 0 Then
            pa.Range = Replace(pa.Range, Chr(13), "") & "()" & Chr(13)
        ElseIf fi = "With" Then
            tf = tf + 1
            strB = strB & Replace(Split(Trim(pa.Range.Text), " ")(1), Chr(13), "") & "@"
            pa.Range = ""
        ElseIf fi = "Set" Then
            re.Pattern = "\.(\w+)\("
            Set sm = re.Execute(pa.Range)
            strA = sm(0).submatches(0)
            pa.Range.Find.Execute findtext:=fi, replacewith:="word." & strA
        ElseIf Left(Trim(pa.Range), 1) = "." Then
            pa.Range = Replace(strB, "@", "") & Trim(pa.Range)
        ElseIf InStr(pa.Range.Text, " .") > 0 Then
            re.Pattern = "\s\."
            If re.test(pa.Range) Then
                st = re.Execute(pa.Range)(0).firstindex
                ActiveDocument.Range(pa.Range.Start + st + 1, pa.Range.Start + st + 1).InsertAfter Replace(strB, "@", "")
            End If
        ElseIf Replace(Trim(pa.Range), Chr(13), "") = "End With" Then
            tf = tf - 1
            strB = Left(strB, InStrRev(strB, "@", Len(strB) - 2))
            pa.Range = ""
        End If
    Next
    re.MultiLine = 1
    re.ignorecase = 1
re.Pattern = "^\s+|Then|End If|End Sub"      '|^Sub.+$^\s*Dim.+$"
Debug.Print re.test(ActiveDocument.Range)
ActiveDocument.Range = re.Replace(ActiveDocument.Range, "")
End Sub

问题源自EH论坛：Excel 一个困扰我很长时间的代码转换问题-Word-ExcelHome技术论坛 -  http://club.excelhome.net/thread-1334942-1-1.html