基于VBA实现Excel多行列合并：合并A-K相同行并整合L列值

第一步：A-K列相同行合并，L列去重合并 #

以下代码会将原数据中A-K列完全一致的行合并，把对应L列的不同值去重后用逗号分隔合并到同一单元格，结果输出到新工作表（避免破坏原数据）：

Sub MergeRowsAKToL()
    Dim wsSource As Worksheet, wsResult As Worksheet
    Dim lastRow As Long, i As Long, j As Long
    Dim dict As Object
    Dim key As String, lValue As String
    Dim colL As Collection
    
    ' 设置源工作表和结果工作表
    Set wsSource = ActiveSheet
    Set wsResult = ThisWorkbook.Worksheets.Add(After:=wsSource)
    wsResult.Name = "合并结果_第一步"
    
    ' 复制表头到结果表
    wsSource.Rows(1).Copy wsResult.Rows(1)
    
    ' 初始化字典（存储A-K列组合键与对应L列去重值集合）
    Set dict = CreateObject("Scripting.Dictionary")
    
    lastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
    
    ' 遍历源数据行
    For i = 2 To lastRow
        ' 生成A-K列的组合键
        key = ""
        For j = 1 To 11 ' A-K列对应序号1-11
            key = key & "|" & wsSource.Cells(i, j).Value
        Next j
        
        lValue = wsSource.Cells(i, 12).Value ' 获取L列值
        
        ' 键不存在则新建集合存储L列值
        If Not dict.Exists(key) Then
            Set colL = New Collection
            On Error Resume Next ' 利用集合键唯一性自动去重
            colL.Add lValue, Key:=CStr(lValue)
            On Error GoTo 0
            dict.Add key, colL
        Else
            ' 键已存在，添加L列值（自动去重）
            Set colL = dict(key)
            On Error Resume Next
            colL.Add lValue, Key:=CStr(lValue)
            On Error GoTo 0
        End If
    Next i
    
    ' 将字典数据写入结果表
    Dim resultRow As Long, k As Variant, item As Variant
    Dim mergedL As String
    resultRow = 2
    
    For Each k In dict.Keys
        ' 拆分组合键，写入A-K列
        Dim keyParts As Variant
        keyParts = Split(k, "|")
        For j = 1 To 11
            wsResult.Cells(resultRow, j).Value = keyParts(j)
        Next j
        
        ' 合并L列去重值
        mergedL = ""
        Set colL = dict(k)
        For Each item In colL
            mergedL = mergedL & item & ","
        Next item
        mergedL = Left(mergedL, Len(mergedL) - 1) ' 移除末尾多余逗号
        wsResult.Cells(resultRow, 12).Value = mergedL
        
        resultRow = resultRow + 1
    Next k
    
    ' 自动调整列宽
    wsResult.Columns.AutoFit
    
    Set dict = Nothing
    Set colL = Nothing
    MsgBox "第一步合并完成，结果已存入工作表：" & wsResult.Name
End Sub

代码说明： #

• 用Scripting.Dictionary确保A-K列组合的唯一性，避免重复行
• 借助Collection的键唯一性特性，自动实现L列值去重
• 结果写入新工作表，防止修改原始数据

第二步：A-J列相同行合并，K、L列分别存入M、N列 #

以下代码实现A-J列相同的行合并，将对应K列的去重值存入M列，L列的去重值存入N列，同样输出到新工作表：

Sub MergeRowsAJToMN()
    Dim wsSource As Worksheet, wsResult As Worksheet
    Dim lastRow As Long, i As Long, j As Long
    Dim dict As Object
    Dim key As String, kValue As String, lValue As String
    Dim colK As Collection, colL As Collection
    
    Set wsSource = ActiveSheet
    Set wsResult = ThisWorkbook.Worksheets.Add(After:=wsSource)
    wsResult.Name = "合并结果_第二步"
    
    ' 复制表头并添加M、N列表头
    wsSource.Rows(1).Copy wsResult.Rows(1)
    wsResult.Cells(1, 13).Value = "合并K列"
    wsResult.Cells(1, 14).Value = "合并L列"
    
    Set dict = CreateObject("Scripting.Dictionary")
    
    lastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
    
    For i = 2 To lastRow
        ' 生成A-J列的组合键
        key = ""
        For j = 1 To 10 ' A-J列对应序号1-10
            key = key & "|" & wsSource.Cells(i, j).Value
        Next j
        
        kValue = wsSource.Cells(i, 11).Value ' 获取K列值
        lValue = wsSource.Cells(i, 12).Value ' 获取L列值
        
        If Not dict.Exists(key) Then
            Set colK = New Collection
            Set colL = New Collection
            
            On Error Resume Next
            colK.Add kValue, Key:=CStr(kValue)
            colL.Add lValue, Key:=CStr(lValue)
            On Error GoTo 0
            
            ' 字典值存储K、L列的去重集合
            dict.Add key, Array(colK, colL)
        Else
            ' 已有键，添加K、L列值（自动去重）
            Set colK = dict(key)(0)
            Set colL = dict(key)(1)
            
            On Error Resume Next
            colK.Add kValue, Key:=CStr(kValue)
            colL.Add lValue, Key:=CStr(lValue)
            On Error GoTo 0
        End If
    Next i
    
    ' 写入结果表
    Dim resultRow As Long, k As Variant, item As Variant
    Dim mergedK As String, mergedL As String
    resultRow = 2
    
    For Each k In dict.Keys
        ' 写入A-J列
        Dim keyParts As Variant
        keyParts = Split(k, "|")
        For j = 1 To 10
            wsResult.Cells(resultRow, j).Value = keyParts(j)
        Next j
        
        ' 合并K列值到M列
        mergedK = ""
        Set colK = dict(k)(0)
        For Each item In colK
            mergedK = mergedK & item & ","
        Next item
        mergedK = Left(mergedK, Len(mergedK) - 1)
        wsResult.Cells(resultRow, 13).Value = mergedK
        
        ' 合并L列值到N列
        mergedL = ""
        Set colL = dict(k)(1)
        For Each item In colL
            mergedL = mergedL & item & ","
        Next item
        mergedL = Left(mergedL, Len(mergedL) - 1)
        wsResult.Cells(resultRow, 14).Value = mergedL
        
        resultRow = resultRow + 1
    Next k
    
    wsResult.Columns.AutoFit
    
    Set dict = Nothing
    Set colK = Nothing
    Set colL = Nothing
    MsgBox "第二步合并完成，结果已存入工作表：" & wsResult.Name
End Sub

使用步骤： #

1. 打开目标Excel文件，按下Alt+F11打开VBA编辑器
2. 右键工程窗口 → 插入 → 模块，将代码粘贴到模块中
3. 返回Excel界面，按下Alt+F8选择对应的子程序运行即可

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