用VBA一次查找到文档中各不相同的重复句子、并用红色标识

13907933959 · 发表于 2016-8-9 11:28

duquancai 发表于 2016-8-9 10:57

前辈好！

好像不成，请看重新上传的附件！

duquancai · 发表于 2016-8-9 11:35

13907933959 发表于 2016-8-9 11:28
前辈好！好像不成，请看重新上传的附件！

标红你所谓的“重复句子”。好不好？

13907933959 · 发表于 2016-8-9 11:39

duquancai 发表于 2016-8-9 11:35
标红你所谓的“重复句子”。好不好？

前辈的意思是？？？

duquancai · 发表于 2016-8-9 11:48

13907933959 发表于 2016-8-9 11:39
前辈的意思是？？？

请看动态图：

13907933959 · 发表于 2016-8-9 12:05

duquancai 发表于 2016-8-9 11:48
请看动态图：

前辈好！
刚才看了您录制的视频，我用也一样有哪个效果，怪我没说清楚，我的意思是说：附件上有十几种不同的相同的重复句子，而每个相同的重复句子又有5～10几句不等，凡是有相同的重复句子全部标为红色，而您给的代码好像只能标注一部分的重复句子。
重复的段落也如上一样。
另外、重复句子的前后都有不同的标点符号。

duquancai · 发表于 2016-8-9 12:48

本帖最后由 duquancai 于 2016-8-9 14:39 编辑

13907933959 发表于 2016-8-9 12:05
前辈好！
刚才看了您录制的视频，我用也一样有哪个效果，怪我没说清楚，我的意思是说：附件上有十几种不 ...

请测试下面的代码：

Sub shishi()
Dim rngtxt As Range, rg As Object, mt, dic As Object, ky
Dim mh, m&, n&, oRang As Range
Set rngtxt = ActiveDocument.Content
Set dic = CreateObject("Scripting.Dictionary")
Set rg = CreateObject("VBScript.Regexp")
On Error Resume Next
With ActiveDocument
rg.Global = True
rg.Pattern = "[^。！？：，、；\r]+?(?=[。！？：，、；])"
For Each mt In rg.Execute(rngtxt)
dic(mt) = ""
Next
For Each ky In dic.Keys
rg.Pattern = ky & "(?=[。！？：，、；])"
If rg.Execute(rngtxt).Count >= 2 Then
For Each mh In rg.Execute(rngtxt)
m = mh.FirstIndex: n = mh.Length
Set oRang = .Range(m, m + n)
oRang.Font.ColorIndex = 6
Next
End If
Next
End With
End Sub

复制代码

13907933959 · 发表于 2016-8-9 17:09

本帖最后由 13907933959 于 2016-8-9 17:17 编辑

duquancai 发表于 2016-8-9 12:48
请测试下面的代码：

前辈好！

下午师傅的诊所里来了几个病人，所以到刚刚才测试，附件上的相同的重复句子，重复段落可准确全部标为红色。

可我在另一个附件上（见附件2）测试，结果却不太理想，如：“寿世传真”…等，可能是前辈的代码具有针对性。

因我有很多文档里面有要删除的重复的句子、段落，它们每个都不太一样，能不能再劳前辈编写一个具有广普性，适应不同的Word文档的，查找这种重复的句子、段落的代码，锁定的标准为一句完整的句子，而不是一部分，也就是整句相同的。（重复的句子、段落，前后同样是有不同的标点符号）只要是这种重复的就标为红色。

duquancai · 发表于 2016-8-9 18:21

本帖最后由 duquancai 于 2016-8-9 18:30 编辑

13907933959 发表于 2016-8-9 17:09
前辈好！下午师傅的诊所里来了几个病人，所以到刚刚才测试，附件上的相同的重复句子，重复段落可准确全部 ...

我现在才发觉我的写的正则表达式是多么的奇怪哎！！！

Sub shishi()
Dim rngtxt As Range, rg As Object, mt, dic As Object, ky
Dim mh, m&, n&, oRang As Range
Set rngtxt = ActiveDocument.Content
Set dic = CreateObject("Scripting.Dictionary")
Set rg = CreateObject("VBScript.Regexp")
On Error Resume Next
With ActiveDocument
rg.Global = True
rg.Pattern = "[。！？：，、；\r]([^\r]+?)(?=[。！？：，、；])"
For Each mt In rg.Execute(rngtxt)
dic(mt.SubMatches(0)) = ""
Next
For Each ky In dic.Keys
rg.Pattern = "[。！？：，、；\r]" & ky & "(?=[。！？：，、；])"
If rg.Execute(rngtxt).Count >= 2 Then
For Each mh In rg.Execute(rngtxt)
m = mh.FirstIndex: n = mh.Length
Set oRang = .Range(m + 1, m + n)
oRang.Font.ColorIndex = 6
Next
End If
Next
End With
End Sub

复制代码

13907933959 · 发表于 2016-8-9 19:12

duquancai 发表于 2016-8-9 18:21
我现在才发觉我的写的正则表达式是多么的奇怪哎！！！

前辈好！
刚刚测试了18楼的代码，还是有部分相同就标红的现象，还是我没有表达清楚。一个标点符号到一个标点符号之间的句子（书名），要全部相同的才似为重复的句子（书名），才标红，无论句子（书名）开头、中间、结尾（不包括标点符号）有一个字不相同的就似为不是重复的句子（书名），不标红。

duquancai · 发表于 2016-8-9 19:17

13907933959 发表于 2016-8-9 19:12
前辈好！
刚刚测试了18楼的代码，还是有部分相同就标红的现象，还是我没有表达清楚。一个标点符号到一个 ...

那一句？请举例，自己认真核对吧！你自己查找吧！标红了的，都是重复了2次及以上。

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

[求助] 用VBA一次查找到文档中各不相同的重复句子、并用红色标识

评分