Excel VBA开发问题：合并同户人员信息生成邮寄标签

刚好我之前处理过类似的邮寄名单合并需求，给你一套实用的VBA代码方案，能精准合并同一Household ID、Salutation、Solicit Description、Street 1/2/3完全一致的人员姓名，方便后续导入Word做标签。

核心思路 #

用字典（Dictionary）来做分组跟踪：把需要匹配的字段拼接成一个唯一"键"，每个键对应一个住户的姓名集合，遍历所有行时，把姓名追加到对应键的集合里，最后把整理好的结果输出到新工作表，避免破坏原数据。

完整VBA代码 #

Sub MergeHouseholdNames()
    Dim wsSource As Worksheet, wsOutput As Worksheet
    Dim lastRow As Long, i As Long
    Dim dict As Object
    Dim key As String
    Dim nameCol As Integer, householdIDCol As Integer, salutationCol As Integer
    Dim solicitDescCol As Integer, street1Col As Integer, street2Col As Integer, street3Col As Integer
    
    ' --------------------------
    ' 这里根据你的实际表格调整列号！
    ' 比如姓名在第2列就设为2，Household ID在第1列设为1，以此类推
    ' --------------------------
    nameCol = 2
    householdIDCol = 1
    salutationCol = 3
    solicitDescCol = 4
    street1Col = 5
    street2Col = 6
    street3Col = 7
    
    ' 初始化源工作表和输出工作表
    Set wsSource = ActiveSheet
    Set wsOutput = ThisWorkbook.Sheets.Add(After:=wsSource)
    wsOutput.Name = "合并后名单"
    
    ' 复制表头到输出表
    wsSource.Rows(1).Copy Destination:=wsOutput.Rows(1)
    
    ' 初始化字典（后期绑定，不用额外引用库）
    Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare ' 不区分大小写匹配，按需调整
    
    lastRow = wsSource.Cells(wsSource.Rows.Count, householdIDCol).End(xlUp).Row
    
    ' 遍历源数据（从第2行开始，跳过表头）
    For i = 2 To lastRow
        ' 生成唯一键：把所有需要匹配的字段拼接在一起
        key = wsSource.Cells(i, householdIDCol).Value & "|" & _
              wsSource.Cells(i, salutationCol).Value & "|" & _
              wsSource.Cells(i, solicitDescCol).Value & "|" & _
              wsSource.Cells(i, street1Col).Value & "|" & _
              wsSource.Cells(i, street2Col).Value & "|" & _
              wsSource.Cells(i, street3Col).Value
        
        ' 如果键不存在，添加新条目，同时记录该行的其他信息
        If Not dict.Exists(key) Then
            ' 存储的是数组：(姓名, 其他字段内容)，这里把除了姓名外的整行内容存下来
            dict.Add key, Array(wsSource.Cells(i, nameCol).Value, wsSource.Rows(i).Value)
        Else
            ' 如果键已存在，追加姓名（用逗号分隔，可改成其他分隔符）
            dict(key)(0) = dict(key)(0) & ", " & wsSource.Cells(i, nameCol).Value
        End If
    Next i
    
    ' 把字典里的结果写入输出表
    Dim outputRow As Long
    outputRow = 2 ' 从第2行开始写数据
    Dim item As Variant
    For Each item In dict.Items
        ' 复制该行的原始内容到输出表
        wsOutput.Rows(outputRow).Value = item(1)
        ' 替换姓名列为合并后的姓名
        wsOutput.Cells(outputRow, nameCol).Value = item(0)
        outputRow = outputRow + 1
    Next item
    
    ' 自动调整输出表列宽
    wsOutput.Columns.AutoFit
    
    MsgBox "合并完成！结果已保存到工作表：" & wsOutput.Name, vbInformation
End Sub

关键细节说明 #

1. 列号调整：代码开头的列号变量一定要对应你的实际表格，比如如果你的Street 1在第6列，就把street1Col = 5改成street1Col = 6。
2. 唯一键的生成：用|作为分隔符拼接所有匹配字段，确保只有当所有指定字段完全一致时才会被归为同一住户，避免误合并。
3. 字典的使用：后期绑定的方式（CreateObject）不需要手动勾选引用库，兼容性更好；如果需要区分大小写匹配，把vbTextCompare改成vbBinaryCompare即可。
4. 姓名分隔符：代码里用的是, 分隔姓名，你可以改成& " / " &或者其他你需要的格式。

使用注意事项 #

• 运行代码前一定要备份原数据，避免意外修改；
• 如果你的表格有特殊格式（比如合并单元格），建议先取消合并再运行；
• 运行后会自动生成名为「合并后名单」的新工作表，所有同户人员的姓名会合并到同一行，其他字段保持不变，直接可以导入Word制作邮寄标签。

内容的提问来源于stack exchange，提问作者Jake