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

13907933959

duquancai 发表于 2019-7-27 13:48
你的需求 不断的改变！下次想清楚了，一次性吐完吧！按照你这次的需求写的，请测试！

杜前辈好！
只能对您再说声抱歉！我知道每一个代码都是各位前辈的辛勤付出，我从来都是怀着敬畏和感恩之心！我也知道代码写成后，求助者更改诉求是大忌！之所以出现这么的笔误，一是自己不够严谨。二是一心两用（在医院当班虽较“清闲”，但也时不时有病人前来打扰）的结果，只能恳求前辈们见谅！
前辈对我是大度和格外照顾的，每次都能援手相帮，这使我很感动！
“3天的消防演习”结束了，对我来说的“假期”也结束了，由于时间关系，30、32楼的代码看了，以后有空测试，30楼的代码在标记重复数，有的有2个是什么意思？32楼的代码标记重复数标红了，让前辈费心了！34楼的代码只粗测了一下，结果准确、以达心意！以后有空再仔细测试。感谢前辈！

13907933959

gbgbxgb 发表于 2019-7-27 13:06
这样的题有深挖掘的必要？显然，可完成目标任务的代码就是好代码，难道要把它写成一个软件？
另：楼主早 ...

gbgbxgb前辈好！
和杜前辈说的话同样对您说一遍，恳求您见谅！
前辈、前几个代码统计结果和我刚开始的要求（不减去标注“重复”字样的本身这一个）确实有误，我也列举了出来，后来我说“描述”有重大笔误，是忘了要减去标注“重复”字样的本身这一个。
由于时间关系，33楼附件中的代码只粗测了一下，结果准确、以达心意！以后有空再仔细测试（因单测试附件中1000多个药名，每个手工查找一遍，恐怕要几个小时）。感谢前辈多次援手相帮！谢谢！

13907933959

413191246se 发表于 2019-7-27 11:56
* 139，我的最新版本《Word2003 & 2007 VBA 自动排版宏（集成版）2019-7-9》中的 2003 版本代码，希望你选 ...

师傅好！
好的、这个《经典代码》我没有掌握，前2年跟师傅和前辈们学的一点皮毛，由于天资和努力不够，再加上整天整夜的学和背中医的东西，现在以忘得差不多了，这很对不起师傅！没有办法，生存的压力大过任何的兴趣和爱好！
师傅的几个代码我也一样等有空再细测，不然等我的中医师傅看到不好，又要挨骂！
感谢师傅为我做的一切！我的中医师傅休息了3天又要来盯我们了，恐怕又没时间来论坛了，如回复不了望师傅见谅！

13907933959

duquancai 发表于 2019-7-27 13:48
你的需求 不断的改变！下次想清楚了，一次性吐完吧！按照你这次的需求写的，请测试！

多回了一个，删除。

413191246se

139：从 Excel 表格对比结果来看，最终，如果从标红角度来讲，gbgbxgb 老师、duquancai 老师和我的代码执行后结果都是正确的；但从执行时间来看，最快速的当属 gbgbxgb 老师，所以，你可以采用 gbgbxgb 老师的代码完成最终定稿（但请注意：gbgbxgb 老师的代码中“重复项 -1”，把这个“-1”删除，就和我的代码执行结果一样了）。

13907933959

413191246se 发表于 2019-7-28 12:04
139：从 Excel 表格对比结果来看，最终，如果从标红角度来讲，gbgbxgb 老师、duquancai 老师和我的代码执行 ...

师傅好！

好的、是 gbgbxgb 老师的这个代码吗？是要删除下面红色代码中的 – 1 吗？

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

        .Content.Find.Execute "（重复[!^13]{1,}", , ,True, , , , , , , wdReplaceAll

        .Range.Font.ColorIndex = wdAuto

        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 - 1 & "个）"

                theStr = reg.Replace(theStr,theStrTemp)

            End If

        Next i

        .Range = theStr

        .Range(.Range.End - 1,.Range.End).Delete

        For Each theMatch In .Paragraphs

            With theMatch

                theStr = .Range

                If InStr(1, theStr, "（") = 0 Then

                    theStr = Replace(theStr,"、","")

                    theStr = Left(theStr,Len(theStr) - 1)

                    If d(theStr) > 1 Then.Range.Font.ColorIndex = wdRed

                End If

            End With

        Next theMatch

    End With

    Set theMatches = Nothing

    Set theMatch = Nothing

    Set d = Nothing

End Sub

ming0018

一般情况下，挤几次牙膏，修改几次命题都是家常便饭了，哈哈哈，淡定！

413191246se

ming 老师 露面了！ 139，是的，j - 1 "个"把“-1”去掉就成了，你可以用 gbgbxgb 老师的代码完成最终定稿。

珍惜的人7758258

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

https://club.excelhome.net/thread-1650662-1-1.html求助