批量清除重复段落

gemj

WORD批量清除重复段落

有时候，需要整理的文档有大量重复的段落，如何批量清除呢？

如果是连续的重复段落：

点击：编辑－替换

勾选通配符

查找内容：(?{1,}^13)\1

替换为：\1

全部替换

重复几次，直到替换处数为0。

如果是不连续的重复段落：

点击：编辑－替换

勾选通配符

查找内容：^13(?{1,}^13)*\1

替换为：^13\1

全部替换

重复几次，只到替换处数为0。

Enjoy!

注意事项：

1、最好先清除多余空行；
2、替换之前，一定把光标放在文章开始处（Ctrl+Home），因为WORD默认是在光标开始处查找。或者全选

文档(Ctrl+A)。

[此贴子已经被作者于2006-12-9 14:25:43编辑过]

gemj

肯定还有更好的办法，请各位大哥指点啊！

linqiang0816

谢谢你的总结。

里面有一点我不是很懂，在“查找和替换”那里，不勾选“通配符”能做到吗？勾选了“通配符”有什么好处？

对于上面注意事项里面的第一点，如果遇到有许多的空行，那如果要事先都删除，那也是一件比较麻烦的事情，应该有更好的的处理方法。

sylun

谢谢分享。

对不连续的情形，楼主替换时是否漏了星号部分的字符串文本，或是想删除它。

gemj

QUOTE:

以下是引用linqiang0816在2006-12-9 15:13:00的发言：

谢谢你的总结。

里面有一点我不是很懂，在“查找和替换”那里，不勾选“通配符”能做到吗？勾选了“通配符”有什么好处？

对于上面注意事项里面的第一点，如果遇到有许多的空行，那如果要事先都删除，那也是一件比较麻烦的事情，应该有更好的的处理方法。

不勾选肯定不行，因为首先"\1"就不支持了。

第二点，清除空行可以用替换命令：把“^13^13”替换为“13”（把每两个段落标记替换为一个），来几次就可以了！

[此贴子已经被作者于2006-12-9 15:35:43编辑过]

gemj

还有，这个命令我用少量的文字测试的时候没问题，但长达几百页，速度还是太慢了。

gemj

QUOTE:

以下是引用sylun在2006-12-9 15:21:18的发言：

谢谢分享。

对不连续的情形，楼主替换时是否漏了星号部分的字符串文本，或是想删除它。

是的，是少了。

对于不连续的情形，应该是：

查找内容：^13(?{1,}^13)(*)\1

替换为：^13\1\2

我用相互交错的几个段落测试时，很好，于是就发上来了！但又用长文档测试时，太慢！而且好象还有些其他问题。

哪位大侠拿出更好的方案？

linqiang0816

谢谢！

konggs

不错。

我也发几个我不久前做的代码。与大家分享。

Sub 删重复行并计数()
    On Error Resume Next '忽略错误
    '++++++++++++++++++++++++++++++++++++++++++
    '要求：1.怎样将相同的行保留一行，但要在最后加上出现次数(此次应该是段的意思)
    '      2.不要格式
    '++++++++++++++++++++++++++++++++++++++++++
    Dim allstring As String  '取得文档所有内容的变量
    Dim arrpar '段落数组
    Dim i As Long '累减的序号
    Dim intlin As Long '每段的字长
    Dim k As Long    '重复的个数
    Dim newstring As String '新的文档内容
   
    allstring = ActiveDocument.Content '取得文档的内容
    allstring = Replace(allstring, Chr(13), Chr(13) & Chr(13)) '替换为双段，以便分开每段
    allstring = Chr(13) & allstring '在文档前加一个回车
    arrpar = Split(allstring, Chr(13)) '分列为数组
    For i = UBound(arrpar) - 1 To 1 Step -1
        intlin = Len(arrpar(i))
        If intlin > 0 Then '如果不是空段落
            k = (Len(allstring) - Len(Replace(allstring, Chr(13) & arrpar(i) & Chr(13), Chr(13)))) / (intlin + 1) '替换后相除即是重复的次数
            '加1是因为段落标记
            If k = 1 Then '如果没有重复
                newstring = arrpar(i) & vbCrLf & newstring '无重复直接加
            ElseIf k > 1 Then '如果有重复
                newstring = arrpar(i) & k & vbCrLf & newstring  '有重复在后面加重复的个数
            End If
                allstring = Replace(allstring, Chr(13) & arrpar(i) & Chr(13), Chr(13)) '删除判断过的内容
        End If
      Next
     
    ActiveDocument.Content = newstring '写入文档
   
End Sub
Sub 删重复段落()

    On Error Resume Next '忽略错误
    '++++++++++++++++++++++++++++++++++++++++++
    '要求：1.怎样将相同的行保留最后的段落
    '      2.要格式
    '      3.速度较慢
    '++++++++++++++++++++++++++++++++++++++++++
    Dim allstring As String  '取得文档所有内容的变量
    Dim i As Long '段落累减的序号
    Dim intlin As Long '每段的字长
    Dim k As Long    '重复的个数
   
    Application.ScreenUpdating = False '关闭屏幕闪幕
    allstring = ActiveDocument.Content '取得文档的内容
    allstring = Replace(allstring, Chr(13), Chr(13) & Chr(13)) '替换为双段，以便分开每段
    For i = ActiveDocument.Paragraphs.Count To 1 Step -1
        intlin = Len(ActiveDocument.Paragraphs(i).Range)
        If intlin > 1 Then '如果不是空段落
            k = (Len(allstring) - Len(Replace(allstring, Chr(13) & ActiveDocument.Paragraphs(i).Range, Chr(13)))) / (intlin + 1) '替换后相除即是重复的次数
            '加1是因为段落标记
            If k = 1 Then '如果没有重复
                 '无重复记录不变
            ElseIf k > 1 Then '如果有重复
               allstring = Replace(allstring, Chr(13) & ActiveDocument.Paragraphs(i).Range, Chr(13), 1, 1) '删除判断过的内容
               ActiveDocument.Paragraphs(i).Range.Delete  '有重复在后面加重复的个数
            End If
        End If
     Next
    Application.ScreenUpdating = False '开启屏幕闪幕
   
End Sub

Sub 删重复段落快()

    On Error Resume Next '忽略错误
    '++++++++++++++++++++++++++++++++++++++++++
    '要求：1.怎样将相同的行保留最后一段
    '      2.不要格式
    '++++++++++++++++++++++++++++++++++++++++++
    Dim allstring As String  '取得文档所有内容的变量
    Dim arrpar '段落数组
    Dim i As Long '累减的序号
    Dim intlin As Long '每段的字长
    Dim k As Long    '重复的个数
    Dim newstring As String '新的文档内容
   
    allstring = ActiveDocument.Content '取得文档的内容
    allstring = Replace(allstring, Chr(13), Chr(13) & Chr(13)) '替换为双段，以便分开每段
    allstring = Chr(13) & allstring '在文档前加一个回车
    arrpar = Split(allstring, Chr(13)) '分列为数组
    For i = UBound(arrpar) - 1 To 1 Step -1
        intlin = Len(arrpar(i))
        If intlin > 0 Then '如果不是空段落
            k = (Len(allstring) - Len(Replace(allstring, Chr(13) & arrpar(i) & Chr(13), Chr(13)))) / (intlin + 1) '替换后相除即是重复的次数
            '加1是因为段落标记
            If k = 1 Then '如果没有重复
                newstring = arrpar(i) & vbCrLf & newstring '无重复直接加
            ElseIf k > 1 Then '如果有重复
                newstring = arrpar(i) & vbCrLf & newstring  '有重复在后面加重复的个数
            End If
                allstring = Replace(allstring, Chr(13) & arrpar(i) & Chr(13), Chr(13)) '删除判断过的内容
        End If
      Next
     
    ActiveDocument.Content = newstring '写入文档
   
End Sub

Sub 排序比较()

    On Error Resume Next '忽略错误
    '++++++++++++++++++++++++++++++++++++++++++
    '要求：1.将相同的行保留第一次出现的
    '      2.要格式
    '      3.破坏原来段落的次序
    '++++++++++++++++++++++++++++++++++++++++++
    Dim par As Paragraph
    '排序比较
    Application.ScreenUpdating = False
   
  ' ActiveDocument.Content.Sort '排序
    With ActiveDocument
        For Each par In .Paragraphs
A:         If par.Range = par.Next.Range Then
            If par.Next.Range Is Nothing Then
                '如果到最后一段了，就没有next了,就跳出
                Exit For
            End If
               par.Next.Range.Delete  '因为删除后，段落数少一个，所以要再判断
               GoTo A:
           End If

        Next
     End With
    
     Application.ScreenUpdating = True
End Sub

gemj

了不起的版主啊！

就是高！