[已解决]VBA删除word中内容完全相同的段落 －死机问题

yjwdjfqb

VBA删除word中内容完全相同的段落　－死机问题

Sub 删除完全重复的段落()

    With CreateObject("vbscript.regexp")
        .Global = True
        .Pattern = "(^|[\r\n])(.*)(?=[\r\n]([\s\S]*[\r\n])*\2([\r\n]|$))"
        If .test(ThisDocument.Range.Text) Then ThisDocument.Range.Text = .Replace(ThisDocument.Range.Text, "$1")
    End With

End Sub


上面代码是从论坛下载的，但在使用的时候，如果文档的内容多的话，就会死机，请大家帮帮提下速度，优化下。谢谢大家了！

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2014-3-12 13:16

1. Sub test()
   
2.     Dim str$, strTemp$
   
3.     Dim d1 As Object
   
4.     Set d1 = CreateObject("Scripting.Dictionary")
   
5.     Dim pg As Paragraph
   
6.     Application.ScreenUpdating = False
   
7.     For Each pg In ThisDocument.Paragraphs
   
8.         strTemp = pg.Range.Text
   
9.         If Len(strTemp) Then
   
10.             If Not d1.Exists(strTemp) Then
    
11.                 d1.Add strTemp, ""
    
12.             Else
    
13.                 pg.Range.Delete
    
14.             End If
    
15.         End If
    
16.     Next
    
17.     Application.ScreenUpdating = False
    
18.     MsgBox "去重复完成"
    
19. End Sub

复制代码

这个你试试，完成后只有5页了。

跳转到最佳答案楼层

hwc2ycy

你的文件内容过多是什么概念，有多少M？
最好把你的附件上传。

yjwdjfqb

hwc2ycy 发表于 2014-3-12 12:08
你的文件内容过多是什么概念，有多少M？
最好把你的附件上传。

测试.rar (11.02 KB, 下载次数: 4)

2014-3-12 12:25 上传

点击文件名下载附件

附件传上，谢谢版主了！

hwc2ycy

1. Sub test()
   
2.     Dim str$, strTemp$
   
3.     Dim d1 As Scripting.Dictionary
   
4.     Set d1 = New Scripting.Dictionary
   
5.     With ThisDocument.Paragraphs
   
6.         For i = 1 To .Count
   
7.             strTemp = .Item(i).Range.Text
   
8.             If Len(strTemp) Then
   
9.                 If Not d1.Exists(strTemp) Then
   
10.                     str = str & strTemp
    
11.                     d1.Add strTemp, ""
    
12.                 End If
    
13.             End If
    
14.         Next
    
15.     End With
    
16.     Set d1 = Nothing
    
17.     ThisDocument.Range.Text = str
    
18. End Sub

复制代码

这个测着玩，不会保留格式，我再改进下。

yjwdjfqb

请大师帮帮忙，谢谢大家了！

hwc2ycy

1. Sub test()
   
2.     Dim str$, strTemp$
   
3.     Dim d1 As Object
   
4.     Set d1 = CreateObject("Scripting.Dictionary")
   
5.     Dim pg As Paragraph
   
6.     Application.ScreenUpdating = False
   
7.     For Each pg In ThisDocument.Paragraphs
   
8.         strTemp = pg.Range.Text
   
9.         If Len(strTemp) Then
   
10.             If Not d1.Exists(strTemp) Then
    
11.                 d1.Add strTemp, ""
    
12.             Else
    
13.                 pg.Range.Delete
    
14.             End If
    
15.         End If
    
16.     Next
    
17.     Application.ScreenUpdating = False
    
18.     MsgBox "去重复完成"
    
19. End Sub

复制代码

这个你试试，完成后只有5页了。

hwc2ycy

原有的格式基本没有修改。

yjwdjfqb

hwc2ycy 发表于 2014-3-12 13:16
这个你试试，完成后只有5页了。

感谢版主的帮助，这个速度超快，太好用了，谢谢了！

yjwdjfqb

hwc2ycy 发表于 2014-3-12 13:16
这个你试试，完成后只有5页了。

版主，刚发现这个问题，能帮帮解决下吗，谢谢版主了！

hwc2ycy

yjwdjfqb 发表于 2014-3-12 14:07
版主，刚发现这个问题，能帮帮解决下吗，谢谢版主了！

做成模块后后，代码里的thisdocument得换成activedocument