请教如何查找并突出显示指定文档的相同内容？

tangqingfu

在http://club.excelhome.net/thread-358299-1-1.html中，我曾问过“如何批量查找（删除）相同的内容”的问题，该问题是针对同一文档；而不适用于不同的文档；今天新开此帖寻求解题的VBA方法：
请教如何查找并标注出指定文档的相同内容？
在同一文档或指定目录下的指定文档中，有些题目在该文档或不同的文档中是重复出现的；请教如何批量查找这些重复的内容并将其用红字字体进行突出显示？
所说的相同内容可以说是绝大多数字符是相同的(其序号可以是相同的，也可以是不同的；空格，标点等细微不同等也可以忽略不计)，分为以下情况：
1、在同一文档中，单项选择题中的第1，5，8小题就是相同的内容;第9和第10小题也是相同的，这样我们就将第5，8，10小题突出显示
2、在同一文档中，在第二大题中，第1,7小题内容相同；第3，10小题内容相同，在查找出相同内容以后，将第7小题和第10小题内容突出显示
3、对于不同文档出现相同的内容，也是按上述方法进行突出显示


该贴已经同步到 tangqingfu的微博

tangqingfu

翻出旧帖，希望能有高人指点，帮写个查找并突出显示活动文档的相同或相似内容的代码？

tangqingfu

看过前版主守柔在本版曾贴过一下“Word文本筛”的图片，是用于文档重复段落和相似段落的分析工具，可惜无下载地址，不知哪位有这样的工具或能写出这样的功能？

zhanglei1371

抛砖引玉：先提供一个思路：
首先按段落循环，将每段分为等长的三部分，然后以每一部分为关键字查找，找到后将关键字所在段内容赋予一个变量，若三部分关键字找到的内容有两部分都对应同一段落，则选定该段落，增加编辑区域。反复循环即可。
若要更精确可分为更多的部分进行查找。
各位若有更好的思路不妨提供出来，有思路就可转化为代码……

tangqingfu

zhanglei1371 发表于 2013-5-14 07:56
抛砖引玉：先提供一个思路：
首先按段落循环，将每段分为等长的三部分，然后以每一部分为关键字查找，找到 ...

无力解决此问题，能否请张兄帮写个代码？
守版的Word文本筛参见：
http://club.excelhome.net/forum.php?mod=viewthread&tid=414999

tangqingfu

zhanglei1371 发表于 2013-5-14 07:56
抛砖引玉：先提供一个思路：
首先按段落循环，将每段分为等长的三部分，然后以每一部分为关键字查找，找到 ...

回过头看，筛选出文档中具有重复的段落（内容），或者相似（相近的）段落（内容），主要还是用于解决活动文档的情况，张兄可以此方向展开思路，可以参考sylun兄的回复或代码
http://club.excelhome.net/thread-358299-1-1.html

zhanglei1371

将sylun的修改下可以得到选中内容：
Sub test()
'引用Microsoft VBScript Regular Expressions 5.5
Dim mytext As String, myExp As New RegExp, myMatches
Dim i As Integer, c As Integer, mystart As Long, myend As Long, myRange As Range, deltext As String
Application.ScreenUpdating = False
mytext = ActiveDocument.Content
With myExp
    .Pattern = "^(\t.+\r)(.+?)(\1)"  '第一个问题的搜索模式
    .Global = True
    .MultiLine = True
    Do  '处理第一个问题，以答案内容（假设均以制表符开头）重复为线索
        Set myMatches = .Execute(mytext)
        If myMatches.Count = 0 Then Exit Do
        For i = myMatches.Count - 1 To 0 Step -1
           c = c + 1
           mystart = myMatches(i).FirstIndex + myMatches(i).Length - Len(myMatches(i).SubMatches(2))
           myend = myMatches(i).FirstIndex + myMatches(i).Length
           Set myRange = ActiveDocument.Range(mystart, myend)
           myRange.MoveStart wdParagraph, -1
                      myRange.Select
                      If myRange.Editors.Count > 0 Then Exit Do
                      Selection.Editors.Add wdEditorEveryone

           mytext = ActiveDocument.Content
        Next
    Loop
    .Pattern = "([\r\t]+\d+\.)(.+?)(\s?[\t\r].+?)(\d+\.\s?\2)"  '第二个问题的搜索模式
    Do  '处理第二个问题
        Set myMatches = .Execute(mytext)
        If myMatches.Count = 0 Then Exit Do
        For i = myMatches.Count - 1 To 0 Step -1
           c = c + 1
           mystart = myMatches(i).FirstIndex + myMatches(i).Length - Len(myMatches(i).SubMatches(3))
           myend = myMatches(i).FirstIndex + myMatches(i).Length
             ActiveDocument.Range(mystart, myend).Select
             If Selection.Editors.Count > 0 Then Exit Do
              Selection.Editors.Add wdEditorEveryone
           mytext = ActiveDocument.Content
        Next
    Loop
End With
    ActiveDocument.SelectAllEditableRanges wdEditorEveryone
    ActiveDocument.DeleteAllEditableRanges wdEditorEveryone
Application.ScreenUpdating = True
End Sub
但只能用于相似度非常高的情况，不高的话没法使用。
八楼的代码我看过了。因为使用了替换。所以变成了文本。以我的水平目前还修改不好，只能期待守柔的文本筛来解决了。。。

zhanglei1371

对于附件中的选择题部分，用这个也可以处理
Sub 查找相似选择题()    '
    On Error Resume Next
    Application.ScreenUpdating = False
    For Each a In ActiveDocument.Range.Paragraphs
        If a.Range.Editors.Count > 0 Then GoTo aaa:
        a.Range.Select
        Selection.EndKey
        b0 = Mid(a, Len(a) / 4, Len(a) / 3)    '对选取内容进行分段，为下面的查找关键字准备
        c0 = Right(a, Len(a) / 3)
        d0 = Mid(a, Len(a) * 2 / 3, Len(a) / 4)
        If Len(a) < 10 Then GoTo aaa:
        With Selection.Find
            .Text = c0
            .Wrap = wdFindStop
            .MatchWildcards = True
            .Forward = True
            If .Execute = False Then
                .Text = b0
            Else
                .Parent.Collapse
                Do While .Execute
                    .Parent.Bookmarks("\para").Select
                    If Selection.Find.Execute(b0) Or Selection.Find.Execute(d0) Then
                        .Parent.Bookmarks("\para").Select
                        Selection.Editors.Add wdEditorEveryone
                    End If
                    Selection.Collapse wdCollapseEnd
                    If ActiveDocument.Range.End - Selection.End < 3 Then GoTo aaa:
                Loop
            End If
        End With
aaa:
    Next
    ActiveDocument.SelectAllEditableRanges wdEditorEveryone
    ActiveDocument.DeleteAllEditableRanges wdEditorEveryone
    Application.ScreenUpdating = True
End Sub
因为是按照段落拆分的，所以填空就不行了，哈哈哈

tangqingfu

zhanglei1371 发表于 2013-5-14 14:59
将sylun的修改下可以得到选中内容：
Sub test()
'引用Microsoft VBScript Regular Expressions 5.5

谢谢张兄！
本楼的代码能够处理选择题与填空题，但在查找的准确性上不如8楼的代码。
能否将代码改为如果有选取区域，则只对选取区域进行处理，否则作全文处理，对于重复的内容按红色进行标注。

tangqingfu

zhanglei1371 发表于 2013-5-14 15:01
对于附件中的选择题部分，用这个也可以处理
Sub 查找相似选择题()    '
    On Error Resume Next

辛苦张兄了！
本楼的代码能够处理选择题，且在查找的准确性上高于7楼的代码；但不能处理填空题的情况！
能否将代码改为如果有选取区域，则只对选取区域进行处理，否则作全文处理，对于重复的内容按红色进行标注。