查找段落中重复药名标红并记数

13907933959 · 发表于 2019-7-26 08:45

本帖最后由 13907933959 于 2019-7-27 09:35 编辑

查找word文档段落中重复的药名，在重复的药名后面标注重复的数量，如：豺肉、共有5个，就在第一个“豺肉”后面标注（重复4个），后面再出现的“豺肉”就不标注了，其它段落中重复的药名以此类推。把后面的重药名标红一下，药名后面查重记了数的除外。

劳请前辈们帮忙写个代码！谢谢！

gbgbxgb · 发表于 2019-7-26 10:21

试试如下代码：

Sub SearchDuplicateStr()
Dim theStr$, d As Object, i&, j&, theStrTemp$
Dim reg As Object, theMatches As Object, theMatch As Variant
'
Set d = CreateObject("Scripting.Dictionary")
Set reg = CreateObject("VBScript.RegExp")
With reg
.Global = True
.MultiLine = True
.Pattern = "^[^、]+"
End With
With ActiveDocument
theStr = .Range
Set theMatches = reg.Execute(theStr)
For Each theMatch In theMatches
theStr = theMatch
d(theStr) = d(theStr) + 1
Next theMatch
reg.Global = False
theStr = .Range
For i = 0 To d.Count - 1
j = d.items()(i)
If j > 1 Then
theStrTemp = d.keys()(i)
reg.Pattern = "^" & theStrTemp & "、"
theStrTemp = theStrTemp & "、（重复" & j & "个）"
theStr = reg.Replace(theStr, theStrTemp)
End If
Next i
.Range = theStr
End With
Set theMatches = Nothing
Set theMatch = Nothing
Set d = Nothing
End Sub

复制代码

ming0018 · 发表于 2019-7-26 10:24

本帖最后由 ming0018 于 2019-7-26 15:20 编辑

Sub main()
Dim doc As Document, Rng As Range, d As Object
Dim arr, i&, n%, tmpstr$
Set doc = ActiveDocument
Set Rng = doc.Content
Set d = CreateObject("scripting.dictionary")
Set reg = CreateObject("VBSCRIPT.REGEXP") 'RegEx为建立正则表达式
Application.ScreenUpdating = False
t = Timer
reg.Global = True: reg.MultiLine = True
arr = Split(Rng.Text, Chr(13))
tmpstr = Rng.Text
For i = 0 To UBound(arr)
If Len(Trim(arr(i))) > 0 Then
reg.Pattern = "^" & arr(i)
Set matchs = reg.Execute(tmpstr)
n = matchs.Count
If n > 1 Then
If Not d.Exists(arr(i)) Then
d(arr(i)) = ""
doc.Range(doc.Paragraphs(i + 1).Range.End - 1, doc.Paragraphs(i + 1).Range.End - 1).Text = "（重复" & n & "个）"
End If
End If
End If
Next i
Application.ScreenUpdating = True
Debug.Print Timer - t
End Sub

复制代码

duquancai · 发表于 2019-7-26 11:13

纯文本可以正则处理，如果不是纯文本建议用find

13907933959 · 发表于 2019-7-26 14:17

本帖最后由 13907933959 于 2019-7-27 07:44 编辑

gbgbxgb 发表于 2019-7-26 10:21
试试如下代码：

好久没来论坛了，我真是运气好，一来就碰到 gbgbxgb ming0018 duquancai 3位 VBA 技术顶级的前辈赐教，万分感谢！

谢谢 gbgbxgb ming0018 两位前辈写的代码，谢谢！

gbgbxgb前辈好！

我粗测了一下您的代码，速度上比 ming0018 前辈的要快一些，总查重药名有288个，而用 ming0018 前辈的代码，总查重药名有295个。两个查重的结果好像都不太准确。

拿“梨”、“梅”两个药材的查重来说，“梨”、查重为20个，结果错误，因只有2个。“梅”查重为2个，这个结果正确。

可能是我没讲清楚，导致您误判！“附件”中，一个段落为一个药名，也就是段落查重。

另外、前辈能不能有办法把后面的重药名标红一下，药名后面查重记了数的除外。

13907933959 · 发表于 2019-7-26 14:19

本帖最后由 13907933959 于 2019-7-26 14:37 编辑

ming0018 发表于 2019-7-26 10:24

ming0018 前辈好！

我粗测了一下前辈您的代码，总查找重复药名有295个，查重的结果好像不太准确。

拿“梨”、“梅”两个药材的查重来说，“梨”、查重为20个，结果错误，因只有2个；“梅”、查重为13个，这个结果也错误，因只有2个。

可能是我没讲清楚，导致您误判！“附件”中，一个段落为一个药名，也就是段落查重。

另外、前辈能不能有办法把后面的重药名标红一下，药名后面查重记了数的除外。

13907933959 · 发表于 2019-7-26 14:20

duquancai 发表于 2019-7-26 11:13
纯文本可以正则处理，如果不是纯文本建议用find

duquancai 前辈好！
是纯word文档，望您赐教！谢谢！

duquancai · 发表于 2019-7-26 15:09

13907933959 发表于 2019-7-26 14:20
duquancai 前辈好！
是纯word文档，望您赐教！谢谢！

哦，纯文本，那楼上的大神写的完全可以了。我没必要再写。如果不是纯文本，倒是可以写一下代码。

ming0018 · 发表于 2019-7-26 15:42

Sub SearchDuplicateStr()
Dim theStr$, d As Object, i&, j&, theStrTemp$
Dim reg As Object, theMatches As Object, theMatch As Variant
'
Set d = CreateObject("Scripting.Dictionary")
Set reg = CreateObject("VBScript.RegExp")
t = timter
With reg
.Global = True
.MultiLine = True
.Pattern = "^[^、]+"
End With
With ActiveDocument
theStr = .Range
Set theMatches = reg.Execute(theStr)
For Each theMatch In theMatches
theStr = theMatch
d(theStr) = d(theStr) + 1
Next theMatch
reg.Global = False
theStr = .Range
For i = 0 To d.Count - 1
j = d.items()(i)
If j > 1 Then
theStrTemp = d.keys()(i)
reg.Pattern = "^" & theStrTemp & "、"
theStrTemp = theStrTemp & "、（重复" & j & "个）"
theStr = reg.Replace(theStr, theStrTemp)
End If
Next i
.Range = theStr
Dim Par As Paragraph
For Each Par In .Paragraphs
theStr = Replace(Par.Range.Text, "、" & Chr(13), "")
If d(theStr) > 1 Then Par.Range.Font.ColorIndex = wdRed
Next
End With
Set theMatches = Nothing
Set theMatch = Nothing
Set d = Nothing
Debug.Print Timer - t
End Sub

复制代码

我的代码效率太低，但我修改后的结果是和gbgbxgb一样的。
另外，需要标红的话，我修改了一下gbgbxgb的代码，你试一下。

ming0018 · 发表于 2019-7-26 16:12

Sub main()
Dim doc As Document, Rng As Range, d As Object
Dim arr, i&, tmpstr$
Set doc = ActiveDocument
Set Rng = doc.Content
Set d = CreateObject("scripting.dictionary")
Application.ScreenUpdating = False
t = Timer
arr = Split(Rng.Text, Chr(13))
tmpstr = Rng.Text
For i = 0 To UBound(arr)
If Len(Trim(arr(i))) > 0 Then
d(arr(i)) = d(arr(i)) + 1
End If
Next i
For i = 0 To UBound(arr)
If d(arr(i)) > 1 Then
doc.Range(doc.Paragraphs(i + 1).Range.End - 1, doc.Paragraphs(i + 1).Range.End - 1).Text = "（重复" & d(arr(i)) & "个）"
d(arr(i)) = -1
ElseIf d(arr(i)) = -1 Then
doc.Paragraphs(i + 1).Range.Font.ColorIndex = wdRed
End If
Next i
Application.ScreenUpdating = True
Debug.Print Timer - t
End Sub

复制代码

这是我根据gbgbxgb的思路又写了一份代码，和gbgbxgb的区别在于，不会改成原文档的格式，缺点就是速度会慢很多。

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

[求助] 查找段落中重复药名标红并记数

评分

评分