短信已收到。 这样行否? Sub newcode() '修改后的代码 On Error Resume Next Dim str() As String, treg(400, 2) As String Dim Lstr As String, f As String Dim hcount As Single, fi1(), fi2() As String Dim wdpath As String hcount = 0 wdpath = ActiveDocument.Path If Right(wdpath, 1) <> "\" Then wdpath = wdpath & "\方案.txt" Open wdpath For Input As #1 Do While Not EOF(1) Line Input #1, Lstr hcount = hcount + 1 '统计替换表的行数 str = Split(Lstr, "→") treg(hcount, 0) = Replace(str(0), """", "", vbTextCompare) '去掉取出字符中的引号 treg(hcount, 1) = Replace(str(1), """", "", vbTextCompare) Loop Close #1 Dim regEx As Object ' 建立变量 Set regEx = CreateObject("vbScript.RegExp") ' 建立正则表达式 Application.ScreenUpdating = False With ActiveDocument '在整个文档内正则替换 regEx.Global = True regEx.multiline = True For p = 1 To .Paragraphs.Count '遍历所有段落 If Len(.Paragraphs(p).Range) = 1 Then GoTo Np '跳过空段落 For i = 1 To hcount If treg(i, 0) = "" And treg(i, 1) = "" Then GoTo NREj regEx.Pattern = treg(i, 0) ' 设置要找的内容 Dim a As Range Set a = .Paragraphs(p).Range a.SetRange a.Start, a.End - 1 a = regEx.Replace(a, treg(i, 1)) '设置替换的内容 NREj: Next Np: Next End With MsgBox "转换完毕!" Application.ScreenUpdating = True End Sub |