多处关键字符替换，要么很慢，要么死机！

tcdatongye · 发表于 2021-4-26 17:13

把、。替换了。，、回车替换了回车

tcdatongye · 发表于 2021-4-26 17:16

半夏降逆也。替换半夏、降逆也。没办法改了

sylun · 发表于 2021-4-26 21:10

可试试如下代码处理效果（仅作无格式文本处理）。注意代码说明及要求。以楼主提供的长文档及药名、关键字符文档测试，在金山word约2分钟，微软word慢些

Sub test()
'测试文档、中药材名录与替换的关键字符3个文档须在同一文件夹内
Dim i%, c%, n%
Dim data$, cmname$(), info$(), findX$(), replaceX$()
Dim st As Single, TF As Boolean
Dim oDoc As Document, RegExp As Object
st = Timer
Set oDoc = ActiveDocument '测试文档为当前活动文档
data = oDoc.Content.Text
Application.ScreenUpdating = False
'提供一个中药材名录文档用于识别药材名，建议按先长后短排序，以减少差错
With Documents.Open(oDoc.Path & "\中药材名录.doc").Content
cmname = Split(.Text, Chr(13)) '只列药材名，每个段落一个药材名
.Parent.Close False
End With
'替换的关键词文档须删除非提取内容段落，且无空段落
With Documents.Open(oDoc.Path & "\替换的关键字符.doc").Content
info = Split(.Text, Chr(13))
.Parent.Close False
End With
Set RegExp = CreateObject("VBScript.RegExp")
'标记药方名，起止位置分别用◇和◆标记，可自行修改与删除
'假设药方名均以“汤”或“丸”字结尾，药材名间可有“加”字
With RegExp
.Global = True
For i = 0 To UBound(cmname) - 1
.Pattern = "(" & cmname(i) & "[汤丸])([^◆])"
If .test(data) = True Then
data = .Replace(data, "◇$1◆$2")
c = c + 1 '所标记的药方计算
End If
Next
Do
TF = False
For i = 0 To UBound(cmname) - 1
.Pattern = "([^◇])(" & cmname(i) & "加?◇)"
If .test(data) = True Then
data = .Replace(data, "$1◇$2")
TF = True
End If
Next
Loop Until TF = False
For i = 0 To UBound(cmname) - 1 '药名间加顿号
.Pattern = "([^◇]" & cmname(i) & ")([^汤丸，。])"
If .test(data) = True Then
data = .Replace(data, "$1、$2")
TF = True
End If
Next
Do
TF = False
.Pattern = "(◇[^◇◆]+)◇([^◇◆]+◆)"
If .test(data) = True Then
data = .Replace(data, "$1$2")
TF = True
End If
Loop Until TF = False
End With
For i = 0 To UBound(info)
If InStr(info(i), "替换为") Then
ReDim Preserve findX(n)
ReDim Preserve replaceX(n)
findX(n) = Split(info(i), "替换为")(0)
replaceX(n) = Split(info(i), "替换为")(1)
n = n + 1
End If
Next
For i = 0 To UBound(findX)
data = Replace(data, findX(i), replaceX(i))
Next
Documents.Add.Content.Text = data
Application.ScreenUpdating = True
MsgBox "处理完毕！处理结果见生成的新文档。用时" & Int(Timer - st) & "秒"
End Sub

复制代码

相见是缘8 · 发表于 2021-4-27 06:52

tcdatongye 发表于 2021-4-26 17:13
把、。替换了。，、回车替换了回车

老师好！
可以了，感谢！
老师，昨天忘了说了，就是能不能同时把替换后的关键字及顿号，也替换一下颜色？如：绿色，我好有作它用。

相见是缘8 · 发表于 2021-4-27 06:53

sylun 发表于 2021-4-26 21:10
可试试如下代码处理效果（仅作无格式文本处理）。注意代码说明及要求。以楼主提供的长文档及药名、关键字符 ...

sylun老师好！
感谢援手！
你说 “测试文档、中药材名录与替换的关键字符3个文档须在同一文件夹内”，我不太明白你说的 “中药材名录” 是那个？……

相见是缘8 · 发表于 2021-4-27 06:59

tcdatongye 发表于 2021-4-26 17:16
半夏降逆也。替换半夏、降逆也。没办法改了

老师，这个我再手动修改！

tcdatongye · 发表于 2021-4-27 09:41

已把所有的替换字体改成蓝色。

sylun · 发表于 2021-4-27 23:59

相见是缘8 发表于 2021-4-27 06:53
sylun老师好！
感谢援手！
你说 “测试文档、中药材名录与替换的关键字符3个文档须在同一文件夹内”， ...

"中药材名录"文档是由自己新建的文档，只是文档中只有中药材名，且每个段落只有一个药材名，就像67楼附件中的《标准》文档，是添加顿号的依据。
下面代码是在前面代码的基础上修改，使比对处理过的部分能在文档中以蓝色字体显示，并且对部分含药材名的方剂以特殊符号标记，以便自行人工审核。

Sub test2()
'测试文档、中药材名录与替换的关键字符3个文档须在同一文件夹内
Dim i%, c%, n%
Dim data$, cmname$(), info$(), findX$(), replaceX$()
Dim st As Single, TF As Boolean
Dim oDoc As Document, RegExp As Object
st = Timer
Set oDoc = ActiveDocument '测试文档为当前活动文档
data = oDoc.Content.Text
Application.ScreenUpdating = False
'提供一个中药材名录文档用于识别药材名，建议按先长后短排序，以减少差错
With Documents.Open(oDoc.Path & "\中药材名录.doc").Content
cmname = Split(.Text, Chr(13)) '只列药材名，每个段落一个药材名
.Parent.Close False
End With
'替换的关键词文档须删除非提取内容段落，且无空段落
With Documents.Open(oDoc.Path & "\替换的关键字符.doc").Content
info = Split(.Text, Chr(13))
.Parent.Close False
End With
Set RegExp = CreateObject("VBScript.RegExp")
'标记药方名，起止位置分别用◇和◆标记，可自行修改与删除
'假设药方名均以“汤”或“丸”字结尾，药材名间可有“加”字
With RegExp
.Global = True
.Pattern = "、+"
data = .Replace(data, "、")
For i = 0 To UBound(cmname) - 1
.Pattern = "(" & cmname(i) & "[汤丸])([^◆])"
If .test(data) = True Then
data = .Replace(data, "◇$1◆$2")
c = c + 1 '所标记的药方计算
End If
Next
Do
TF = False
For i = 0 To UBound(cmname) - 1
.Pattern = "([^◇])(" & cmname(i) & "加?◇)"
If .test(data) = True Then
data = .Replace(data, "$1◇$2")
TF = True
End If
Next
Loop Until TF = False
For i = 0 To UBound(cmname) - 1 '药名间加顿号
.Pattern = "([^◇])(" & cmname(i) & ")([^汤丸、，；。])"
If .test(data) = True Then
data = .Replace(data, "$1△$2、▲$3")
TF = True
End If
Next
Do
TF = False
.Pattern = "(◇[^◇◆]+)◇([^◇◆]+◆)"
If .test(data) = True Then
data = .Replace(data, "$1$2")
TF = True
End If
Loop Until TF = False
End With
For i = 0 To UBound(info)
If InStr(info(i), "替换为") Then
ReDim Preserve findX(n)
ReDim Preserve replaceX(n)
findX(n) = Split(info(i), "替换为")(0)
replaceX(n) = Split(info(i), "替换为")(1)
n = n + 1
End If
Next
For i = 0 To UBound(findX)
data = Replace(data, findX(i), "△" & replaceX(i) & "▲")
Next
With Documents.Add.Content.Find
.Parent.Text = data
.Text = "[◇△][!◇◆△▲]@[◆▲]"
.MatchWildcards = True
.Replacement.Font.ColorIndex = wdBlue
.Execute replacewith:="^&", Replace:=wdReplaceAll
.Format = False
' .Execute findtext:="◇[!◇◆]@◆", Replace:=wdReplaceAll
.Execute findtext:="[△▲]", replacewith:="", Replace:=wdReplaceAll
End With
Application.ScreenUpdating = True
MsgBox "处理完毕！处理结果见生成的新文档。用时" & Int(Timer - st) & "秒"
End Sub

复制代码

相见是缘8 · 发表于 2021-4-28 07:10

sylun 发表于 2021-4-27 23:59
"中药材名录"文档是由自己新建的文档，只是文档中只有中药材名，且每个段落只有一个药材名，就像67楼附件 ...

sylun老师好！

你看一下，是不是这样的？我试了2次，不知什么原因，代码都是运行了27分钟左右后死机。

相见是缘8 · 发表于 2021-4-28 07:12

tcdatongye 发表于 2021-4-27 09:41
已把所有的替换字体改成蓝色。

老师好！
代码OK了！万分感谢你！！！

		自动登录	找回密码
密码			免费注册

[求助] 多处关键字符替换，要么很慢，要么死机！