查找重复段落的宏，您有现成的吗？

chuhua

我一片文档里 有很多题目
这样的
1.题目1题目1题目1题目1题目1题目1题目1题目1题目1题目1题目1题目1题目1题目1题目1题目1题目1题目1题目1题目1题目1题目1题目1题目1题目1题目1题目1题目1题目1题目1题目1题目1题目1题目1题目1题目1题目1题目1题目1。【蓝色】
1.答案：解析题目1题目1题目1题目1。
其中题目是黑色的答案是红色的，中间还有蓝色的字
一个word文件里上百道题
但是不可避免有重复的
就是除了序号以外的文字是重复的
我找网友做了一个宏但是如果文档长的话一运行就死机
因为文档50页以上的
这个宏我贴出来
大家看看有没有好的改进方案，不死机
运行快的  查找重复段落 但是序号又不算
Sub 查重复的题目()
    Dim myParagraph As Paragraph, myRange As Range, aRange As Range
    Dim aNumStr As String
    Dim I As Long, CP As Long
    For Each myParagraph In ActiveDocument.Paragraphs
        CP = CP + 1
        Set myRange = myParagraph.Range
        myRange.End = myRange.End - 1
        If InStr(1, myRange.Text, ".") > 1 And InStr(1, myRange.Text, ".") < 5 Then
            aNumStr = Replace(Mid(myRange.Text, 1, InStr(1, myRange.Text, ".")), " ", "")
            If IsNumeric(aNumStr) Then
                For I = CP To ActiveDocument.Paragraphs.Count
                    If I > CP Then
                        Set aRange = ActiveDocument.Paragraphs(I).Range
                        aRange.End = aRange.End - 1
If Mid(aRange.Text, Len(aNumStr) + 1) = Mid(myRange.Text, Len(aNumStr) + 1) Then aRange.Font.Color = wdColorBlue
                    End If
                Next
            Else
                For I = CP To ActiveDocument.Paragraphs.Count
                    If I > CP Then
                        Set aRange = ActiveDocument.Paragraphs(I).Range
                        aRange.End = aRange.End - 1
                        If aRange.Text = myRange.Text Then aRange.Font.Color = wdColorBlue
                    End If
                Next
            End If
        End If
    Next
End Sub

请高手指教
我再发个图片

Admin

   

很遗憾通知楼上朋友，您的帖子在24小时之内没有任何回复！

通常情况下，本论坛发布的主题帖会在8小时被回复或处理。您的帖子在24小时之内未被回复，其中的原因可能是：

1、问题表述不清、模棱两可，难以理解，帮助者被搞晕了，夺帖而出；
2、没有上传必要的附件，或附件被遗忘在某个角落；
3、发帖提问时，语气带棱角、带挑衅，不幸被列入不受欢迎的帖子；
4、所提问题不成立，或提不合理的要求，乐于助人者使出“走为上”之计；
5、话题较偏、较冷或者发布到了不合适的版块，暂时无人问津，顾影自怜。


为了提高您的问题解决效率，我们推荐您阅读以下文章：
* 如何发表新话题和上传附件：http://club.excelhome.net/thread-45649-1-1.html
* 发帖的技巧：http://club.excelhome.net/thread-176339-1-1.html
* EH技术论坛的最佳学习方法：http://club.excelhome.net/thread-117862-1-1.html

chylhr

试试如下代码:
Sub Test()
   Dim myPar As Paragraph, myRange As Range, myFindRange As Range, I As Integer
   For Each myPar In ActiveDocument.Paragraphs
      I = InStr(1, myPar.Range, ".")
      Set myFindRange = myPar.Range
      myFindRange.Start = myFindRange.Start + I
      myFindRange.End = myFindRange.End - 1
      If myFindRange.Font.Color <> wdColorBlue Then
         Set myRange = ActiveDocument.Range(myPar.Range.End - 1, ActiveDocument.Content.End)
         With myRange.Find
            .ClearFormatting
            With .Replacement
              .ClearFormatting
              .Font.Color = wdColorBlue
            End With
         End With
         myRange.Find.Execute FindText:=myFindRange.Text, Replace:=wdReplaceAll, Wrap:=wdFindStop
      End If
   Next
   MsgBox "ok"
End Sub

tangqingfu

谢谢chylhr兄的分享！效果不错！
只是运行后提示：“运行时错误："5854" 字符串参量过长”
可否将代码修改为：如果有选定内容，则只对选定内容进行处理，否则全文档处理？能否再添加对重复段落(序号不同，内容相同的也算是重复内容或重复段落)自动删除处理的程序?

chylhr

原帖由 tangqingfu 于 2011-8-12 00:46 发表
谢谢chylhr兄的分享！效果不错！
只是运行后提示：“运行时错误："5854" 字符串参量过长”
可否将代码修改为：如果有选定内容，则只对选定内容进行处理，否则全文档处理？能否再添加对重复段落(序号不同，内容相同 ...

1、关于“运行时错误："5854" 字符串参量过长”：
答：参数FindText所支持的最长字符串为256个字符，当超过此数量时，就会出现此错误。下面的新代码已修正。
2、关于“如果有选定内容，则只对选定内容进行处理，否则全文档处理？”：
答：下面的新代码已增加此功能。
3、关于“能否再添加对重复段落(序号不同，内容相同的也算是重复内容或重复段落)自动删除处理的程序？”
答：将下面新代码稍做更改即可：将“.Font.Color = wdColorBlue”删除，且将“myRange.Find.Execute FindText:=myFindStr, Replace:=wdReplaceAll, Wrap:=wdFindStop”更改为“myRange.Find.Execute FindText:=myFindStr, Replace:=wdReplaceAll, Wrap:=wdFindStop, ReplaceWith:=""”即可。

新代码如下:
Sub Test()
   Dim myPar As Paragraph, myRange As Range, FindArea As Range, myFindRange As Range, myFindStr As String, I As Integer
   If Selection.Paragraphs.Count >= 8 Then
      Set FindArea = Selection.Range
   Else
      Set FindArea = ActiveDocument.Content
   End If
   For Each myPar In FindArea.Paragraphs
      I = InStr(1, myPar.Range, ".")
      Set myFindRange = myPar.Range
      myFindRange.Start = myFindRange.Start + I
      On Error Resume Next
      myFindStr = "[0-9]{1,}." & Left(myFindRange, 3) & "*" & Right(myPar.Next.Next.Next.Range, 6)
      If myFindRange.Font.Color <> wdColorBlue Then
         Set myRange = ActiveDocument.Range(myPar.Range.End - 1, FindArea.End)
         With myRange.Find
            .ClearFormatting
            .MatchWildcards = True
            With .Replacement
              .ClearFormatting
              .Font.Color = wdColorBlue
            End With
         End With
         myRange.Find.Execute FindText:=myFindStr, Replace:=wdReplaceAll, Wrap:=wdFindStop
      End If
   Next
   MsgBox "ok"
End Sub

绿竹清茶

不会用啊，运行后弹出窗口“ok“还是看不出重复段落

chylhr

绿竹清茶 发表于 2011-8-14 19:55
不会用啊，运行后弹出窗口“ok“还是看不出重复段落

代码只针对1楼楼主的文档.

chuhua

chylhr 发表于 2011-8-12 18:22
1、关于“运行时错误："5854" 字符串参量过长”：
答：参数FindText所支持的最长字符串为256个字符，当 ...

重复的怎么处理了？请教

bxlzbtpap

你是要标记重复，还是要删除重复？
最好把实际文档传上来，偶也试试。

chylhr

chuhua 发表于 2011-8-31 17:10
重复的怎么处理了？请教

1、根据楼主1楼的代码，只是将重复的字体改为兰色；
2、如果你想将重复的删除，可查看5楼代码前的说明。