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

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

复制代码

413191246se · 发表于 2019-7-27 12:15

* 139，在测试时，不管发现哪位老师的测试结果，如果有一个词不正确，就可以判断为：代码错误！希求老师重新编码以求正确结果（先从最短词汇测试校对，用我的 EXCEL对照表）。可以公布一下结果。

duquancai · 发表于 2019-7-27 12:59

13907933959 发表于 2019-7-27 09:31
前辈、抱歉！抱歉！才发现描述有重大笔误！
查找word文档段落中重复的药名，在重复的药名后面标注重复的 ...

请测试》》》》》》》》》》》》》》

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, i 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))
With doc.Range(n, n)
If .MoveEndWhile("（") <> 1 Then
.InsertAfter "（重复" & d(key(i)) - 1 & "个）"
.MoveEndUntil vbCr
.Font.ColorIndex = 6
End If
End With
End If
Next
End Sub

复制代码

gbgbxgb · 发表于 2019-7-27 13:06

413191246se 发表于 2019-7-27 12:15
* 139，在测试时，不管发现哪位老师的测试结果，如果有一个词不正确，就可以判断为：代码错误！希求老师重 ...

这样的题有深挖掘的必要？显然，可完成目标任务的代码就是好代码，难道要把它写成一个软件？
另：楼主早先一直跟帖说我们几个人的代码统计有误。我对此一直纳闷。我们统计的结果与楼主附件中的要求是一致的，这可通过手工查找来对正。楼主后来自行纠正说附件中的“描述”有重大笔误，却原来是统计的数量结果要排除标注“重复”字样的本身这一个。

回到你的楼层，提供附件代码供检测。

duquancai · 发表于 2019-7-27 13:48

本帖最后由 duquancai 于 2019-7-27 15:52 编辑

13907933959 发表于 2019-7-27 09:31
前辈、抱歉！抱歉！才发现描述有重大笔误！
查找word文档段落中重复的药名，在重复的药名后面标注重复的 ...

你的需求不断的改变！下次想清楚了，一次性吐完吧！按照你这次的需求写的，请测试！

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, mhs As Object, n&, i&, j&, flag As Boolean, t&
key = d.keys()
Set re = CreateObject("VBScript.Regexp")
re.Global = True: re.MultiLine = True
For i = 0 To UBound(key)
If d(key(i)) > 1 Then
re.Pattern = "^" & key(i): flag = False: t = 0
Set mhs = re.Execute(doc.Content.Text)
For j = 0 To mhs.Count - 1
n = mhs(j).FirstIndex
If Not flag Then
With doc.Range(n, n + Len(key(i)))
If .MoveEndWhile("（") = 1 Then Exit For
.InsertAfter "（重复" & d(key(i)) - 1 & "个）"
t = Len("（重复" & d(key(i)) - 1 & "个）")
End With
flag = True
Else
doc.Range(n + t, t + n + Len(key(i))).Font.ColorIndex = 6
End If
Next
End If
Next
End Sub

复制代码

413191246se · 发表于 2019-7-27 14:03

* gbgbxgb 老师，您好！——我早注意到您了，但我现在不得不衷心地说，您太厉害了！以后我就称您为老师了！请笑纳。
*
* 正则代码如表中显示，您的代码执行速度是最快的。正则我还一点不会。我觉得还是按我徒弟 139 所要求对代码精益求精一下比较好。
*
* 今天凌晨，经我几易其稿后，发现，我徒弟 139 的这道题，用杜老师(duquancai)的话说就是，有“坑”！
刚开始，我发现每个词，后面必须是“顿号、”截止；后来，发现不仅如此，前面还要有符号来代表起始，用回车符也行，我用了个笨办法，每段前面加了一个小撇儿（‘），后来觉得还是找到每个词后，只要判断前一字符是回车符（13）即可，这样，每位老师的代码可能就不会有问题了！
*
* 刚才又看了一下各位老师的代码，因为不懂正则，现在我最推崇的是 zhangelei1371 老师的代码，他的代码就是最普通又经典的《循环遍历段落法ForEachNext》集合遍历法，因为代码最少，速度仅次于老师您的代码，所以我最喜欢 zhanglei1371 老师的代码（我判断他的代码结果现在是错误的，因为没有判断前一字符是回车或加小撇儿‘）。
*
* 各位老师/高人/大神在一起 VS 一下代码，我觉得总是有高有低，有快有慢，做个比较是正常的。
*
* 如果您有兴趣的话，建议重新推敲一下代码，重新审视一下是否彻底正确地解决了我徒弟 139 的问题。
*
* 谢谢！

413191246se · 发表于 2019-7-27 14:12

gbgbxgb 老师，您好！请不要生气！人的认识是一步一步发展的，我刚开始比较武断，判定各位老师的代码结果不正确，后来逐步认识到问题不太简单。比如：我徒弟 139 这道题，“刺梨”和“刺梨根”不一样，后来发现还有“山刺梨”，后面有顿号截止，前面怎么限定一个词？就是回车或加一字符（如小撇儿‘）。否则，查找结果就不对了。

gbgbxgb · 发表于 2019-7-27 14:25

413191246se 发表于 2019-7-27 14:12
gbgbxgb 老师，您好！请不要生气！人的认识是一步一步发展的，我刚开始比较武断，判定各位老师的代码 ...

我没生气啊。
看来我用“？”表述疑问让你产生了语句中含有“火药味”了，下回我注意尽量用陈述句，不用问句或感叹句。

另：VBA代码过度关注代码的效率完全没必要。当然了，你也说了，你想要代码精益求精，甚至想让代码既精简又高效，那才是好代码。但遗憾的是，往往精简的代码却不周到，可能错漏百出。
还是一句话表明我对VBA的看法：它仅是办公的得力助手，自己写的且能完成目标的就是最适合的代码，哪怕它有缺陷。因为日后工作中发现代码存在错漏了，那么，再慢慢完善它也不迟。你说呢？（原谅我又用“？”了，^_^）

413191246se · 发表于 2019-7-27 20:41

* gbgbxgb 老师，您没生气，太好了！咱们又可以做朋友了！——我来论坛也有 8 年了吧，2011年7月上本坛的。过去，曾经学习过 VB6，但最终连一个计算器都不会编。后来，在工作中，日益熟悉了一些 Word 用法，像“邮件合并”功能，是自学的，这点现在很多人还不会哩！
*
* 再后来，直到 2011年7月吧，突然灵机一动，有一次偶然的机会，我就到 VBE 中改了改代码（其实在 VB6 中我已经在 VBE 中学习过一阵子，但在 WORD 中竟然不懂！），至此，一发不可收拾，就开始喜欢 VBA 编程了，开始是一直利用录制宏这个便利方法学习的。后来，学习了 VBA 微软官方帮助文档，又找了一本电子书《VBA从入门到精通第二版》和《守柔VBA代码集》等，逐步入门。但感觉进步最大的还是近几年得益于杜老师（duquancai）等一些高人大神的帮助，从一些VBA“方法”，到简写方法。目前，感觉初步掌握了 VBA 的一些查找方法，算法朴素，代码初步，深感与各位老师的差距还是很大的，我还得向各位老师学习（现在仅初步掌握VBA查找方法，数组、函数、递归、字典、正则等统统不会）。

413191246se · 发表于 2019-7-27 22:09

* 139，我重新提供一下最新VBA代码对照结果，gbgbxgb 老师和 duquancai 老师都重新提供了代码。
* EXCEL对照表：

139vs2.rar (64.65 KB, 下载次数: 6)
* VBA结果对照：

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

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

评分