删除不同章节下的重复段落

duquancai · 发表于 2017-10-27 22:01

本帖最后由 duquancai 于 2017-10-27 22:06 编辑

chenwenming 发表于 2017-10-27 21:35
谢谢！测试了一下，速度是快的，但没有实现删除的黄色重复行，而是删除的重复第一行

我告诉你，只要是重复的段落（甭管重复1次还是2次还是N次，也甭管是相邻的还是不相邻的段落重复）都会被删除而保留唯一段落，自己出的题目难道这个道理都不明白，我还能说什么呢？无语！以后我不再回复你的贴。

duquancai · 发表于 2017-10-27 22:01

本帖最后由 duquancai 于 2017-10-27 22:08 编辑

chenwenming 发表于 2017-10-27 21:35
谢谢！测试了一下，速度是快的，但没有实现删除的黄色重复行，而是删除的重复第一行

我告诉你，只要是重复的段落（甭管重复1次还是2次还是N次，也甭管是相邻的还是不相邻的段落重复）都会被删除而保留唯一段落，自己出的题目难道这个道理都不明白，我还能说什么呢？无语！以后我不再回复你的贴。

chenwenming · 发表于 2017-10-27 22:31

本帖最后由 chenwenming 于 2017-10-30 08:25 编辑

duquancai 发表于 2017-10-27 22:01
我告诉你，只要是重复的段落（甭管重复1次还是2次还是N次，也甭管是相邻的还是不相邻的段落重复）都会被 ...

可能怪我题目没说明白，其实一般来讲如果段落重复都是保留第一个段落的，如果两个段落之间如果有正文就会将原属于这个段落的正文并到上个段落，这两天仔细研究了一下杜前辈的代码，确实很优秀，比我的好多了，高人就是高人哪！佩服佩服！

chenwenming · 发表于 2017-11-4 08:38

本帖最后由 chenwenming 于 2017-11-4 17:45 编辑

一高人的指点（针对附件1）：
Sub test()
'Dim reg As New RegExp
Dim reg As Object
Dim dic, dic2, dic3 As Object
Dim p As Paragraph
'Dim dic As New Scripting.Dictionary
Set dic = CreateObject("scripting.dictionary")
'Dim dic2, dic3 As Scripting.Dictionary
level1 = ""
level2 = ""
For Each p In ActiveDocument.Paragraphs
Set reg = CreateObject("vbscript.regexp")
reg.Pattern = "^\s*[一二三四五六七八九十]+、"
If reg.test(p.Range.Text) Then
Set dic2 = CreateObject("scripting.dictionary")
'Set dic2 = New Scripting.Dictionary
dic.Add p.Range.Text, dic2
level1 = p.Range.Text
GoTo next1
End If
reg.Pattern = "^\s*[0-9]+、"
If reg.test(p.Range.Text) And level1 <> "" Then
If Not (dic(level1).Exists(p.Range.Text)) Then
Set dic3 = CreateObject("scripting.dictionary")
'Set dic3 = New Scripting.Dictionary
dic(level1).Add p.Range.Text, dic3
End If
level2 = p.Range.Text
GoTo next1
End If
reg.Pattern = "^\s*[A-Z]+、"
If reg.test(p.Range.Text) And level2 <> "" Then
If Not (dic(level1)(level2).Exists(p.Range.Text)) Then
dic(level1)(level2).Add p.Range.Text, ""
p.Range.HighlightColorIndex = wdAuto
Else
'p.Range.HighlightColorIndex = wdYellow
p.Range.Delete
End If
End If
next1:
Next
End Sub

复制代码

chenwenming · 发表于 2017-11-4 08:55

本帖最后由 chenwenming 于 2017-11-4 17:44 编辑

再附上我一直崇拜的龚老师的代码（针对附件1）：

Sub DelSamePara()
On Error Resume Next
Dim ParaXml() As String
Dim ParaText() As String
Dim TextPart() As String
Dim TextNum As Long
Dim OpenXml() As String
Dim NeedDel() As Boolean
Dim XmlPartNum As Long
Dim ParaNum As Long
Dim BefBody As String
Dim AftBody As String
Dim i As Long
Dim j As Long
Dim k As Long
Dim ParaPartIndex As Long
Dim SubStart As Long
OpenXml = Split(ActiveDocument.Range.WordOpenXML, "<pkg:part pkg:name=")
XmlPartNum = UBound(OpenXml)
For i = 0 To XmlPartNum
If Left$(OpenXml(i), 120) = """/word/document.xml"" pkg:contentType=""application/vnd.openxmlformats-officedocument.wordprocessingml.document.main+xml"">" Then
ParaPartIndex = i
BefBody = Left$(OpenXml(i), InStr(OpenXml(i), "<w:body>") + 7)
OpenXml(i) = Right$(OpenXml(i), Len(OpenXml(i)) - Len(BefBody))
AftBody = Right$(OpenXml(i), Len(OpenXml(i)) - InStrRev(OpenXml(i), "</w:body>") + 1)
OpenXml(i) = Left$(OpenXml(i), Len(OpenXml(i)) - Len(AftBody))
ParaXml = Split(OpenXml(i), "</w:p>")
ParaNum = UBound(ParaXml) - 1
Exit For
End If
Next
If ParaNum > 0 Then
ReDim ParaText(ParaNum) As String
For j = 0 To ParaNum
TextPart = Split(ParaXml(j), "</w:t>")
TextNum = UBound(TextPart) - 1
For i = 0 To TextNum
TextPart(i) = Right$(TextPart(i), Len(TextPart(i)) - InStrRev(TextPart(i), ">"))
Next
TextPart(i) = ""
ParaText(j) = Replace$(Trim$(Join(TextPart, "")), " ", "")
Next
End If
'下面是你要怎么判断标题开头，标题结束，设置需要删除的规则,你的文档表达不清楚，请根据自己的需要修改。
ReDim NeedDel(ParaNum) As Boolean
For i = 0 To ParaNum
If ParaText(i) Like "#、*" Or ParaText(i) Like "##、*" Or ParaText(i) Like "[一二三四五六七八九○零十百]*" Then
For j = i - 1 To SubStart Step -1
For k = j - 1 To SubStart Step -1
If ParaText(j) = ParaText(k) Then
NeedDel(j) = True
Exit For
End If
Next
Next
SubStart = i
End If
Next
For i = 0 To ParaNum
If NeedDel(i) = True Then
ParaXml(i) = Left$(ParaXml(i), InStr(ParaXml(i), "<w:p ") - 1)
Else
ParaXml(i) = ParaXml(i) & "</w:p>"
End If
Next
OpenXml(ParaPartIndex) = BefBody & (Join(ParaXml, "") & AftBody)
ActiveDocument.Range.InsertXML Join(OpenXml, "<pkg:part pkg:name=")
End Sub

复制代码

loquat · 发表于 2017-11-4 08:57

既然都上正则，其实我有一个想法，仅供参考
查询一次，标记重复项，并将每个重复项标记序号：例如﨩001-你的内容，第1个可以不标
最后统一查找一次将带序号的都干掉

没有看前文的代码，不知道这个方案的效率会咋样

duquancai · 发表于 2017-11-4 11:35

chenwenming 发表于 2017-11-4 08:38

删除不同章节下的重复段落
本事例：删除第一层次下的重复段落，不删除表格内有重复段落的情况，不改变其文档原格式
第一层次下的手动编号如下格式：一、这是第一层标题：类型1
............
............
中间可能有表格，图片、图形等对象
............
二、这是第一层标题：类型2
............
............
中间可能有表格，图片、图形等对象
............

Sub 删除不同章节下的重复段落()
Dim myStart&, P As Range, b As Boolean
With ActiveDocument.Content.Find
Do While .Execute("[一二三四五六七八九〇百千万]@、", , , 1, , , 0)
With .Parent
If Not b Then
Set P = ActiveDocument.Range(.Start, ActiveDocument.Content.End)
Call Delete_duplicate_paragraphs(P): b = True
Else
Set P = ActiveDocument.Range(.Start, myStart)
Call Delete_duplicate_paragraphs(P)
End If
myStart = .Start: .Collapse
End With
Loop
End With
End Sub
Sub Delete_duplicate_paragraphs(ByVal myRange As Range)
Dim d As Object, i&
Set d = CreateObject("Scripting.Dictionary")
With myRange
For i = .Paragraphs.Count To 2 Step -1
If Not .Paragraphs(i).Range.Information(12) Then
If Not d.Exists(.Paragraphs(i).Range.Text) Then
Set d(.Paragraphs(i).Range.Text) = .Paragraphs(i).Range
Else
d(.Paragraphs(i).Range.Text).Text = Empty
Set d(.Paragraphs(i).Range.Text) = .Paragraphs(i).Range
End If
End If
Next
End With
Set d = Nothing
End Sub

复制代码

loquat · 发表于 2017-11-4 19:48

龚老师的想法别出心裁，直接处理xml

chenwenming · 发表于 2017-11-4 19:54

loquat 发表于 2017-11-4 19:48
龚老师的想法别出心裁，直接处理xml

是啊，高手中的高手！

tangqingfu · 发表于 2021-3-21 17:57

做个标记，学习下……

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

[原创] 删除不同章节下的重复段落