Sub 删除重复段落方案一DeleteDuplicateParagraphs()
Dim p1 As Paragraph
Dim p2 As Paragraph
Dim DupCount As Long
Dim StartTime As Double
Dim SecondsElapsed As Double
StartTime = Timer
For Each p1 In ActiveDocument.Paragraphs
If p1.Range.Text <> vbCr Then
For Each p2 In ActiveDocument.Paragraphs
If p1.Range.Text = p2.Range.Text Then
DupCount = DupCount + 1
If p1.Range.Text = p2.Range.Text And DupCount > 1 Then p2.Range.Delete
End If
Next p2
End If
DupCount = 0
Next p1
SecondsElapsed = Round(Timer - StartTime, 2)
MsgBox 'This code ran successfully in ' & SecondsElapsed & ' seconds', vbInformation
DupCount = 0
End Sub
p1(1)循环结束,开始继续进行p1(2)循环,然后p2继续从p2(1)到p2(9)。
这个方案,设计思路上比较好理解,但是会随着段落数的增加,循环次数会呈现平方倍的增加,也就是代码执行效率会下降,这个可以通过里面的另外一个计时函数timer来进行对比。整个循环结束,会用消息框来提示代码的执行时间。
Sub 删除重复段落方案二DeleteDuplicateParagraphs()
Set d = CreateObject('Scripting.Dictionary')
Dim p As Paragraph
Dim t As Variant
Dim i As Integer
Dim StartTime As Single
StartTime = Timer
' collect duplicates 收集重复项
For Each p In ActiveDocument.Paragraphs
t = p.Range.Text
If t <> vbCr Then
If Not d.Exists(t) Then d.Add t, CreateObject('Scripting.Dictionary')
d(t).Add d(t).Count + 1, p
End If
Next
' eliminate duplicates 删除重复项
Application.ScreenUpdating = False
For Each t In d
For i = 2 To d(t).Count
d(t)(i).Range.Delete
Next
Next
Application.ScreenUpdating = True
MsgBox 'This code ran successfully in ' & Round(Timer - StartTime, 2) & ' seconds', vbInformation
End Sub
联系客服