Excel VBA需求：按多列重复项拼接A列值至对应列下方

需求说明 #

开发宏实现以下功能：

• 针对B列、C列（及其他指定列），按列内重复值分组，将对应A列的单元格值拼接
• 同一重复组内的A列值无空格拼接，不同重复组之间用英文句号.分隔
• 结果输出到对应列的数据下方第一个空单元格；若无法实现该格式，也可将各重复组的值放在对应列的不同单元格

示例效果

已尝试代码 #

Sub ConcatenateCellsIfSameValues()
Dim xCol As New Collection
Dim xSrc As Variant
Dim xSrcValue As Variant
Dim xRes() As Variant
Dim i As Long
Dim J As Long
Dim xRg As Range
Dim xResultAddress As String
Dim xMergeAddress As String
Dim xUp As Variant

'xResultAddress = "C24" 'The cell to output the results
xMergeAddress = "A" 'The column you will combine based on the duplicates in column A

xSrc = Range("D1", Cells(Rows.count, "D").End(xlUp)).Resize(, 1)
xUp = Range("D1", Cells(Rows.count, "D").End(xlUp)).Rows.count
xSrcValue = Range(xMergeAddress & "1:" & xMergeAddress & xUp)

If ActiveWindow.RangeSelection.count > 1 Then
xTxt = ActiveWindow.RangeSelection.AddressLocal
Else
xTxt = ActiveSheet.UsedRange.AddressLocal
End If
Set xRg = Application.InputBox("Selecciona celda output", "Output", , , , , , 8)
If xRg Is Nothing Then Exit Sub
On Error Resume Next
For i = 2 To UBound(xSrc)
xCol.Add xSrc(i, 1), TypeName(xSrc(i, 1)) & CStr(xSrc(i, 1))
Next i

On Error GoTo 0
ReDim xRes(1 To xCol.count + 1, 1 To 2)
'xRes(1, 1) = "No" - Not needed
'xRes(1, 2) = "Combined Color" - Not needed
For i = 1 To xCol.count
xRes(i + 1, 1) = xCol(i)
For J = 2 To UBound(xSrc)
If xSrc(J, 1) = xRes(i + 1, 1) Then
xRes(i + 1, 2) = xRes(i + 1, 2) & vbCr & xSrcValue(J, 1)
End If
Next J
xRes(i + 1, 2) = Mid(xRes(i + 1, 2), 2)
Next i
Set xRg = xRg.Resize(UBound(xRes, 1), UBound(xRes, 2))
xRg.NumberFormat = "@"
xRg = xRes
xRg.EntireColumn.AutoFit
End Sub

可实现的解决方案 #

该需求完全可以实现，以下是适配需求的宏代码：

Sub ConcatenateByColumnDuplicates()
    Dim ws As Worksheet
    Dim targetCols As Variant
    Dim lastRow As Long, outputRow As Long
    Dim cellValue As String
    Dim groupDict As Object ' 存储每个分组对应的A列拼接值
    Dim colIdx As Integer, i As Long
    Dim resultStr As String
    
    ' 设置目标列（这里是B、C列，可根据需求修改，比如添加"D,E"）
    targetCols = Array("B", "C")
    Set ws = ActiveSheet
    Set groupDict = CreateObject("Scripting.Dictionary")
    
    ' 遍历每个目标列
    For colIdx = LBound(targetCols) To UBound(targetCols)
        ' 获取当前列的最后一行数据
        lastRow = ws.Cells(ws.Rows.Count, targetCols(colIdx)).End(xlUp).Row
        ' 输出行设为数据行的下一行（留一行空行，和示例一致）
        outputRow = lastRow + 2
        
        ' 清空字典，准备处理当前列
        groupDict.RemoveAll
        resultStr = ""
        
        ' 遍历当前列的每一行数据（从第2行开始，假设第1行是表头）
        For i = 2 To lastRow
            cellValue = ws.Cells(i, targetCols(colIdx)).Value
            ' 如果字典中没有该值，添加并初始化拼接值为对应A列内容
            If Not groupDict.Exists(cellValue) Then
                groupDict(cellValue) = ws.Cells(i, "A").Value
            Else
                ' 如果已存在，追加对应A列内容
                groupDict(cellValue) = groupDict(cellValue) & ws.Cells(i, "A").Value
            End If
        Next i
        
        ' 将字典中的所有分组拼接值用句号分隔
        resultStr = Join(groupDict.Items(), ".")
        
        ' 输出结果到对应列的指定行
        ws.Cells(outputRow, targetCols(colIdx)).Value = resultStr
        ' 设置单元格为文本格式，避免特殊字符问题
        ws.Cells(outputRow, targetCols(colIdx)).NumberFormat = "@"
    Next colIdx
    
    MsgBox "拼接完成！", vbInformation
End Sub

代码说明

• 目标列设置：通过targetCols = Array("B", "C")指定要处理的列，可自行添加其他列（如Array("B","C","D")）
• 分组逻辑：使用字典（Dictionary）存储每个重复值对应的A列拼接结果，自动去重分组
• 输出位置：自动将结果输出到对应列数据下方第2行（留一行空行，和示例一致）
• 格式处理：设置单元格为文本格式，避免拼接结果出现格式异常

备选方案（分组值分单元格输出） #

如果需要将每个分组的拼接值放在对应列的不同单元格，可替换上述代码中的结果输出部分为：

' 替换原结果输出代码段
outputRow = lastRow + 2
' 遍历字典，逐个输出分组值
For Each key In groupDict.Keys
    ws.Cells(outputRow, targetCols(colIdx)).Value = groupDict(key)
    outputRow = outputRow + 1
Next key

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