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

chuhua · 发表于 2011-8-9 20:41

我一片文档里有很多题目
这样的
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 · 发表于 2011-8-11 07:05

很遗憾通知楼上朋友，您的帖子在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 · 发表于 2011-8-11 18:17

试试如下代码:
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 · 发表于 2011-8-12 00:46

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

chylhr · 发表于 2011-8-12 18:22

原帖由 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

绿竹清茶 · 发表于 2011-8-14 19:55

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

chylhr · 发表于 2011-8-15 07:57

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

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

chuhua · 发表于 2011-8-31 17:10

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

重复的怎么处理了？请教

bxlzbtpap · 发表于 2011-9-1 00:24

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

chylhr · 发表于 2011-9-1 07:52

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

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

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

[求助] 查找重复段落的宏，您有现成的吗？

〖Excel Home友情提示〗