[求助]如何批量查找（删除）相同的内容

尝试用正则表达式搜索。对第一个问题，因所称要删除小题题目除序号以外的内容也并非是完全相同的，很难把握（这点楼主最好能自己总结出来），故程序选择以答案内容相同为线索，当然这可能会导致对答案内容相同但问题内容不同的的条目进行删除。

请测试，不知程序处理的速度如何。

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
           deltext = deltext & "第" & c & "处：" & vbCrLf & myRange & vbCrLf
           myRange.Delete
           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
           deltext = deltext & "第" & c & "处：" & vbCrLf & ActiveDocument.Range(mystart, myend) & vbCrLf
           ActiveDocument.Range(mystart, myend).Delete
           mytext = ActiveDocument.Content
        Next
    Loop
End With
Documents.Add.Content = deltext
MsgBox "共删除了" & c & "答案内容重复之处，删除的内容见生成的新文档。"
Application.ScreenUpdating = True
End Sub

对于正则表达式,我还是相当陌生。

对于哪些是同样的内容，我不知能否表述得清楚？

在一楼附件中，有一题是用选择题的形式，sylun兄的程序以答案内容相同为线索，但如果在答案内容相同的情况下，选项之间的有些是以空格（全角空格，半角空格等）的形式出现，有些又是以制表符的形式出现，（但我们还是视这样的内容是相同的内容，也就是说，以文字为标准，可以忽略空格、字体格式或段落样式）那又该如何处理?

比如有些内容本身不是选择题，上面的方法就失效了，请教sylun兄，这样的情况该如何处理？

PS:我所谓的相同内容,就段落而言,可以忽略段落前面的序号,中英文破折号、点号等标点符号的差别,也可以忽略段落格式,空格等；也可可忽略字体格式.

我觉得，对大文档的处理，统一规范的排版格式很重要，是处理的前提条件，否则，要准确查找并处理重复的内容很难。所以，感觉应先对文档进行统一格式，而不是故意添加空格之类，造成不规范。我也曾做过复习题，一般是一小题一个段落，小题内须换行的用手动换行符，全角半角空格、括号之类也统一用其中一种。字符格式应只起区别作用，而不是添乱。

没见过楼主的其他题目，其他不好说。

3楼所说的附件如下,不知好不好解决?(有点惟恐天下不乱的感觉)

如sylun兄所言,复习题一般是一小题一个段落，小题内须换行的用手动换行符，全角半角空格、括号之类也统一用其中一种。字符格式应只起区别作用，而不是添乱。

三楼其他要求,我倒是找到了些代码,或通过其他方式可以解决.

我主要还是想解决附件中第二页的问题(即查找相同(内容)的段落并其多余的部分删除)

能否请sylun兄及诸位版友帮忙写个代码?

2mF3AaKh.rar (6.81 KB, 下载次数: 84)

2008-10-4 06:19 上传

点击文件名下载附件

就附件第二页的内容，我想主要是小题开头编号文本问题，如果其后的内容已作规范处理，可以试试如下代码。还是用正则，处理速度不详。

Sub test2()
'选中第二页的内容再运行
Dim otext As String, myExp As New RegExp, mytext As String
otext = Selection.Text
With myExp
    .Pattern = "(^[0-9]+)([.、．][\s　]*)"
    .Global = True
    .Multiline = True
    otext = .Replace(otext, "$1．")
    .Pattern = "^(\d+．)(.+\r)(.*?)(\d+．\2)"
    Do
        mytext = .Replace(otext, "$1$2$3")
        If mytext = otext Then Exit Do
        otext = mytext
    Loop
End With
'Selection.Text = mytext
Documents.Add.Content = mytext
End Sub

请教sylun兄:

1、在处理一楼第二个问题时,感觉sylun兄的代码是以制表符为标记进行执行代码的,请教能否加入半角空格,全角空格及不间断空格的情况(即题与题之间是以半角空格,全角空格或不间断空格隔开)?

2、关于6楼代码的测试:

在新文档中产生删除内容的新文档,但原档没有发生变化.请sylun兄帮忙再解决一下?

3、能否将2楼和6楼的二段代码合并成一个？

4、能否使上述的代码做到在选中的状态下，只删除选中的内容；没选中的状态下，则全文进行查找删除？

6楼代码已提供在原文档进行文本替换的语句选择（下同）。

以下代码针对上面几个问题修改，并作某些规范处理，主要功能包括：统一小题编号格式、统一小题编号前的空白字符格式、统一破折号字符、删除主要内容重复的段落（以括号及编号开头的）、'删除内容重复的段落（段首为制表符）、删除内容重复的小题（开头为段首或制表符）、删除段末空白字符。程序只作纯文本处理，且不记录删除内容。请自行测试。

Sub test3()
'引用Microsoft VBScript Regular Expressions 5.5
Dim myExp As New RegExp, mySearch, myReplace, myRange As Range, otext As String, mytext As String, i As Byte
mySearch = Array("(\d+)([.、．]+[ 　]*)", "([ \xA0\t　]+)(\d+\. )", "-{2,3}", "^([ \(\)　]+\d+\. )(.+?\r)(.+?)^[ \(\)　]+\d+\. \2", _
       "(^\t.+\r)(.*?)(\1)", "(^\d+\. |\t\d+\. )(.+?)([\r\t].+?[\r\t])\d+\. \2", "(^|^\d+\. )(.+?\r)(.*?)(\2|\d+\. \2)", "\s*$")
myReplace = Array("$1. ", vbTab & "$2", ChrW(8212), "$1$2$3", "$1$2", "$1$2$3", "$1$2$3", "")
Set myRange = IIf(Selection.Type = wdSelectionIP, ActiveDocument.Content, Selection.Range) '没有选定内容则进行全文档处理
otext = myRange.Text
With myExp
    .Global = True
    .Multiline = True
    For i = 0 To UBound(mySearch)  '按照搜索模式与替换代码数组数据对指定文本进行处理
        .Pattern = mySearch(i)
        Do
            mytext = .Replace(otext, myReplace(i))
            If mytext = otext Then Exit Do
            otext = mytext
        Loop
    Next
End With
'myRange.Text = mytext  '文档文本替换
Documents.Add.Content = mytext  '处理结果以新文档输出
End Sub

感觉运行起来效果挺不错的,谢谢sylun兄的鼎立帮助.但在下面的附件中,发现第二大题目的第12小题与第6小题是相同的,却没有查找到并将其删除.请sylun兄帮忙解决.

JHvEqJnc.rar (4.55 KB, 下载次数: 59)

2008-10-7 20:11 上传

点击文件名下载附件

对楼主这样的回复感到有点意外。如果是指前一个第“二”大题第12小题与第4小题的内容“相同”问题，请楼主仔细比较原文档中两小题编号之后的内容是否完全相同。对此情形，楼主之前并无提及，之前附件也并无出现，故程序不与考虑。虽程序最后也用到删除段末空白字符，但当时的想法主要在于删除处理过程中可能产生的段末空白。其实该问题解决起来也简单，可先手工处理再运行程序，也可以在两数组中各增加一个元素并作为第一个元素，其值取最后一个元素的值。