Word VBA地址去重：如何修改代码以实现单词级重复行匹配而非段落匹配

嘿，看你现在遇到的地址去重问题比之前更棘手了——不仅有整段重复的情况，还有地址行分散在不同位置重复的场景，对吧？我来帮你调整代码，搞定这些五花八门的重复问题，最终得到干净的唯一地址块。

先理清楚核心需求：不管重复的地址行是连续堆在一起，还是零散分布，我们要把所有重复的行（包括类似邮编这种部分重复的）去重，只保留一套完整的地址信息。

核心思路拆解 #

• 先把目标区域里的所有文本拆成单独的行（不管原来是不是独立段落），这样就能统一处理分散的重复行
• 对所有行做去重：先过滤完全重复的，再针对邮编这种有细微差异的行做特殊处理（优先保留信息更完整的版本）
• 最后把去重后的行重新写入文档，恢复干净的地址格式

调整后的VBA代码 #

Sub RemoveDuplicateAddressLines()
    Dim targetRange As Range
    Dim allLines As Collection
    Dim lineText As String
    Dim para As Paragraph
    Dim splitLines() As String
    Dim i As Integer, j As Integer
    Dim isDuplicate As Boolean
    Dim uniqueLines As Collection
    
    ' 这里可以替换成你原来定位标签区域的代码，先默认用选中区域测试
    Set targetRange = Selection.Range
    Set allLines = New Collection
    Set uniqueLines = New Collection
    
    ' 第一步：把所有段落拆成单独的行，收集起来（跳过空行）
    For Each para In targetRange.Paragraphs
        splitLines = Split(Trim(para.Range.Text), vbCr)
        For i = LBound(splitLines) To UBound(splitLines)
            lineText = Trim(splitLines(i))
            If lineText <> "" Then
                allLines.Add lineText
            End If
        Next i
    Next para
    
    ' 第二步：去重逻辑，处理完全重复+邮编类部分重复
    For i = 1 To allLines.Count
        lineText = allLines(i)
        isDuplicate = False
        
        ' 先检查是否已有完全重复的行
        For j = 1 To uniqueLines.Count
            If uniqueLines(j) = lineText Then
                isDuplicate = True
                Exit For
            End If
            
            ' 针对邮编行的特殊处理：同一前缀的邮编，保留更完整的版本
            If InStr(lineText, ", RC ") > 0 Then
                Dim currentZipPrefix As String, existingZipPrefix As String
                currentZipPrefix = Split(Split(lineText, "RC ")(1), "-")(0)
                existingZipPrefix = Split(Split(uniqueLines(j), "RC ")(1), "-")(0)
                
                If currentZipPrefix = existingZipPrefix Then
                    ' 当前行更长（带后缀），就替换掉已有的短版邮编
                    If Len(lineText) > Len(uniqueLines(j)) Then
                        uniqueLines.Remove j
                    ' 当前行是短版，标记为重复跳过
                    Else
                        isDuplicate = True
                        Exit For
                    End If
                End If
            End If
        Next j
        
        If Not isDuplicate Then
            uniqueLines.Add lineText
        End If
    Next i
    
    ' 第三步：清空原区域，写入去重后的干净地址
    targetRange.Delete
    Set targetRange = Selection.Range
    For i = 1 To uniqueLines.Count
        targetRange.Text = uniqueLines(i) & vbCr
        Set targetRange = targetRange.Next
    Next i
End Sub

关键细节说明 #

• 跨行收集文本：不管原来的地址是按段落分还是按换行分，都拆成单独的行，这样就能处理你例子里那种分散的重复行
• 邮编特殊处理：针对你例子里邮编带后缀和不带后缀的情况，自动保留信息更完整的版本（带-1234的）
• 灵活定位区域：如果你的代码是通过标签定位区域，把Set targetRange = Selection.Range替换成你原来的区域定位逻辑就行

测试建议 #

先选中一段你提供的测试地址，运行这个宏看看效果，如果还有其他特殊的重复场景（比如街道简写/全称重复），可以在去重逻辑里再添加对应的判断条件就行。

备注：内容来源于stack exchange，提问作者Caim31