不错。 我也发几个我不久前做的代码。与大家分享。 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
|