修改Excel VBA代码实现多列按唯一ID合并数据

原代码仅支持A、B两列合并，要实现多列合并，需调整数据读取、字典存储和结果生成的逻辑，以下是修改后的完整代码：

Sub CombineMultiColumns()
    ' 源工作表配置
    Const sName As String = "Test"
    Const sDelimiter As String = ", "
    ' 目标工作表配置
    Const dName As String = "Test2"
    Const dFirstCellAddress As String = "A2"
    Const dDelimiter As String = ", "
    
    Dim wsSource As Worksheet
    Set wsSource = ThisWorkbook.Worksheets(sName)
    
    ' 读取源数据区域（包含所有列）
    Dim sourceRange As Range
    Set sourceRange = wsSource.Range("A1").CurrentRegion
    Dim rCount As Long, cCount As Long
    rCount = sourceRange.Rows.Count - 1 ' 排除表头行数
    cCount = sourceRange.Columns.Count   ' 获取总列数
    
    If rCount < 1 Then Exit Sub ' 无数据或仅有表头，直接退出
    
    ' 将源数据存入数组（从第2行开始，所有列）
    Dim Data As Variant
    Data = sourceRange.Resize(rCount, cCount).Offset(1).Value
    
    ' 构建双层字典：外层键为唯一ID，内层为列索引对应的值字典（用于去重）
    Dim dict As Object
    Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare ' 不区分大小写
    
    Dim Key As Variant
    Dim col As Long, row As Long
    Dim cellValue As String
    Dim valueArr As Variant
    Dim innerDict As Object
    
    For row = 1 To rCount
        Key = Data(row, 1) ' A列作为唯一ID
        ' 跳过ID为空或错误值的行
        If Not IsError(Key) And Len(CStr(Key)) > 0 Then
            ' 如果ID不存在，为其创建对应各列的字典集合
            If Not dict.Exists(Key) Then
                Set dict(Key) = CreateObject("Scripting.Dictionary")
                ' 为每一列初始化一个空字典
                For col = 2 To cCount
                    Set dict(Key)(col) = CreateObject("Scripting.Dictionary")
                    dict(Key)(col).CompareMode = vbTextCompare
                Next col
            End If
            
            ' 遍历当前行的所有列（从第2列开始）
            For col = 2 To cCount
                cellValue = CStr(Data(row, col))
                ' 跳过错误值和空值
                If Not IsError(cellValue) And Len(cellValue) > 0 Then
                    ' 拆分已有分隔符的值（如果原单元格已有逗号分隔）
                    valueArr = Split(cellValue, sDelimiter)
                    ' 将每个值存入对应列的字典（自动去重）
                    For Each val In valueArr
                        dict(Key)(col)(Trim(val)) = Empty ' Trim去除前后空格
                    Next val
                End If
            Next col
        End If
    Next row
    
    If dict.Count = 0 Then Exit Sub ' 无有效数据，退出
    
    ' 重新调整数组大小，适配结果行数和列数
    ReDim Data(1 To dict.Count, 1 To cCount)
    row = 0
    
    ' 将字典中的数据写入结果数组
    For Each Key In dict.keys
        row = row + 1
        Data(row, 1) = Key ' 写入唯一ID
        ' 遍历每一列，合并对应的值
        For col = 2 To cCount
            If dict(Key)(col).Count > 0 Then
                Data(row, col) = Join(dict(Key)(col).keys, dDelimiter)
            Else
                Data(row, col) = "" ' 无数据则留空
            End If
        Next col
    Next Key
    
    ' 将结果写入目标工作表
    Dim wsDest As Worksheet
    Set wsDest = ThisWorkbook.Worksheets(dName)
    Dim destRange As Range
    Set destRange = wsDest.Range(dFirstCellAddress).Resize(dict.Count, cCount)
    
    ' 写入数据并清除后续旧数据
    destRange.Value = Data
    destRange.Resize(wsDest.Rows.Count - destRange.Row - dict.Count + 1).Offset(dict.Count).Clear
    
    MsgBox "多列数据合并完成。", vbInformation
End Sub

关键修改说明 #

• 数据读取范围：原代码仅读取前2列，修改后读取源数据区域的所有列，通过cCount = sourceRange.Columns.Count获取总列数。
• 字典结构优化：外层字典以A列ID为键，内层为列索引对应的子字典，用于存储每列的不重复值（保持原代码去重逻辑）。
• 多列循环处理：新增列循环For col = 2 To cCount，遍历处理每一列的数据，拆分、去重后存入对应子字典。
• 结果数组适配：重新定义结果数组时，列数设为总列数cCount，写入时遍历每一列合并对应的值。
• 目标区域写入：写入目标区域时，按总列数调整范围，确保所有列的数据都能正确输出。

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