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

duquancai · 发表于 2019-7-26 21:39

zhanglei1371 发表于 2019-7-26 20:55
我也来个简单版的：

针对纯文本，你这“算法”很好！！！

413191246se · 发表于 2019-7-26 23:09

本帖最后由 413191246se 于 2019-7-27 11:40 编辑

* 徒弟 139 你好！好久不见了！看到你的题目，等我忙了半天想发表，结果发现各位老师已经抢先了！

413191246se · 发表于 2019-7-27 01:57

* 楼上图片及EXCEL数据有错！
*
* 如果哪位老师看到，对不起！我弄错了，现更正如下：（原来“山刺梨”和“刺梨”还不是一回事！我是觉得后面有顿号、截住，原来前面也要有符号，我用小撇儿`放在每个段落的前面，现在估计数据是正确的了！）
* 查找重复药品名称VBA代码VS结果对照表：

vs139.rar (57.15 KB, 下载次数: 3)
* 查找重复药品名称VBA代码VS结果对照图：

13907933959 · 发表于 2019-7-27 07:37

zhanglei1371 发表于 2019-7-26 20:55
我也来个简单版的：

前辈好！
粗测了一下您的代码，速度很快，但查重结果好像不太准确，我只测了“梨”和“梅”两个药材的查重结果，原本各有2个；而您的代码查重为无。

13907933959 · 发表于 2019-7-27 07:39

duquancai 发表于 2019-7-26 21:05
没时间考虑算法，也就不管效率了！！！

杜前辈好！
哈哈！您的代码查重结果好像也不太准确，“梅”的查重结果，原本有2个，而您的代码查重为无。

13907933959 · 发表于 2019-7-27 09:12

413191246se 发表于 2019-7-27 01:57
* 楼上图片及EXCEL数据有错！
*
* 如果哪位老师看到，对不起！我弄错了，现更正如下：（原来“山刺梨”和 ...

师傅好！
好久不见，甚是想念！
您的回复早上都没显示出来，刚刚才看到，让师傅费心了！
这几天医院的人都参加市内组织的消防演习，较清闲，本想把2万多种中药材名作一个简单的整理，对重复的药材名标注重复次数，没想到因水平未到，搞了几个小时都没搞定，只能上论坛来向前辈们求助。
师傅您的这个对照表真是太捧了，什么都一目了然。代码的快慢不是排第一位，准确率才是第一位！从目前粗测来看，ming0018 前辈10楼的代码准确率最高。
师傅、怎么没看到您的代码？

13907933959 · 发表于 2019-7-27 09:31

ming0018 发表于 2019-7-26 16:12
这是我根据gbgbxgb的思路又写了一份代码，和gbgbxgb的区别在于，不会改成原文档的格式，缺点就是速度会 ...

前辈、抱歉！抱歉！才发现描述有重大笔误！
查找word文档段落中重复的药名，在重复的药名后面标注重复的数量，如：豺肉、共有5个，就在第一个“豺肉”后面标注（重复4个），后面再出现的“豺肉”就不标注了，其它段落中重复的药名以此类推。把后面的重药名标红一下，药名后面查重记了数的除外。
劳请前辈你帮忙修改一下代码！谢谢！

413191246se · 发表于 2019-7-27 11:49

* 139 你好！我的代码，实际上，已经几易其稿了，因为照各位老师比，水平很低，另外对于每个段落中的药品名称也没掌握好，所以，实际上是今天早上凌晨，才醒悟过来，每个段落的文字，即药品，后面有顿号做标记，前面开始没有；我后来发现“山刺梨”和“刺梨”有重复，所以，决定每个段落前要加一个小撇儿'，这样，每个段落的药品才会是唯一的了！——到底哪位老师的代码是最正确的（100%），还请你仔细测试一下。
*
* 我的代码因为就是普通的 VBA 查找，水平所限，很费时，当然也有一部分原因是，我的代码前部分是初始化准备，就是当一个药名后面没有“顿号、”时，前部分初始化会自动加一个顿号；其它比如，药名中有空格、有假回车、有域等都要删除变得正常后，再查找重复药名，很费时间，大约一分钟多，请你耐心等待，继而测试一下（EXCEL对照表中，1代表相等，0代码不相等）。师傅水平低，敬请见谅！
*
* 我的代码：

Sub aaab查找重复药品名称()
Dim j As Paragraph
With ActiveDocument
.Content.Find.Execute "[^13^11]", , , 1, , , , , , "^p", 2
.Fields.Unlink
.ConvertNumbersToText
.Select
With Selection
.Font.Underline = wdUnderlineNone
CommandBars.FindControl(ID:=122).Execute
CommandBars.FindControl(ID:=123).Execute
With .Find
.ClearFormatting
.Execute "^w", , , 0, , , , , , "", 2
.Execute "　", , , 0, , , , , , "", 2
End With
End With
For Each j In .Paragraphs
If Asc(j.Range) = 13 Then j.Range.Delete
Next
.Content.Find.Execute "([!、])(^13)", , , 1, , , , , , "\1、\2", 2
With .Paragraphs.Last.Range
If .Text = vbCr Then .Delete
End With
.Content.Find.Execute "^p", , , , , , , , , "^p`", 2
.Paragraphs.Last.Range.Delete
.Content.InsertBefore Text:="`"
End With
'End Sub
'Sub aaab查找重复药品名称222()
Dim r As Range, a As Range, s As Range, i$, n&
With Selection
.WholeStory
.InsertBefore Text:=vbCr
Set r = .Range
Set a = .Range
Set s = .Paragraphs(1).Range
End With
Do
Set s = s.Next(4, 1)
If s.Underline = wdUnderlineSingle Then GoTo sk
With r.Find
.ClearFormatting
i = s.Text
i = Left(i, Len(i) - 1)
.Text = i
.Forward = True
.MatchWildcards = True
Do While .Execute
With .Parent
.MoveEnd
.Underline = wdUnderlineSingle
n = n + 1
If n >= 2 Then .Font.Color = wdColorRed
.Start = .End
End With
Loop
If n >= 2 Then s.Characters.Last.InsertBefore Text:="（重复" & n & "个）"
n = 0
r.SetRange Start:=s.End, End:=a.End
End With
sk:
Loop Until s.End = a.End
With ActiveDocument.Content
.Paragraphs(1).Range.Delete
.Underline = wdUnderlineNone
.Find.Execute "`", , , , , , , , , "", 2
End With
End Sub

复制代码

413191246se · 发表于 2019-7-27 11:56

本帖最后由 413191246se 于 2019-7-27 12:11 编辑

* 139，我的最新版本《Word2003 & 2007 VBA 自动排版宏（集成版）2019-7-9》中的 2003 版本代码，希望你选用，这是目前最新最好版本了！（我曾经几次想优化，发现速度不进反退，作罢！）平时简单地排版一下很好，另外你有什么好的建议也可以提出来。如果觉得好，也可以推荐给其他人。*
* 我现在是 WinXP 下联合使用：Word2003 & Word2007（但在我的电脑上，2007运行很慢，不如2003快，因为它需要内存多）。*
* 你的问题提得很好！引得好几位老师/高手/大神竞相献艺。以后在整理医学文献时，可以自行设计，有问题就来论坛提出问题（当然开始自己用录制宏的方式自行研究也很好）。
*
* 下面是将你上面标红代码，删除标红词汇的代码（不需要可以不保留，就是一句代码。这个《经典代码》我不知道你掌握没有？很好用、很简单。实际上，我很想用这个经典代码来设计排版程序，但速度上会大打折扣——我过去是个五笔打字爱好者，打多少字都不怕，现在打得少了，总搞代码）。

Sub a经典代码_循环遍历段落法_ForEachNext_删除红色词汇()
Dim i As Paragraph
For Each i In ActiveDocument.Paragraphs
If i.Range.Font.Color = wdColorRed Then i.Range.Delete
Next
End Sub

复制代码

duquancai · 发表于 2019-7-27 11:57

本帖最后由 duquancai 于 2019-7-27 12:19 编辑

13907933959 发表于 2019-7-27 07:39
杜前辈好！
哈哈！您的代码查重结果好像也不太准确，“梅”的查重结果，原本有2个，而您的代码查重为无 ...

请试试》》》》》》》

Sub main()
Dim doc As Document, d As Object
Set doc = ActiveDocument
Set d = CreateObject("Scripting.Dictionary")
Call get_num(doc, d)
Call mark_num(doc, d)
End Sub
Sub get_num(ByVal doc As Document, ByRef d As Object)
Dim re As Object, mh As Object
Set re = CreateObject("VBScript.Regexp")
re.Global = True: re.MultiLine = True
re.Pattern = "^[^、]+"
For Each mh In re.Execute(doc.Content.Text)
d(mh.Value) = d(mh.Value) + 1
Next
End Sub
Sub mark_num(ByRef doc As Document, ByVal d As Object)
Dim key, re As Object, mh As Object, n As Long
key = d.keys()
Set re = CreateObject("VBScript.Regexp")
re.MultiLine = True
For i = 0 To UBound(key)
If d(key(i)) > 1 Then
re.Pattern = "^" & key(i)
Set mh = re.Execute(doc.Content.Text)
n = mh(0).FirstIndex + Len(key(i)) + 1
With doc.Range(n, n)
If .MoveEndWhile("（") <> 1 Then .InsertAfter "（重复" & d(key(i)) - 1 & "个）"
End With
End If
Next
End Sub

复制代码

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

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