如何通过VBA循环根据A列条件合并B列单元格？

你需要实现A列值相同时，合并对应B列的值到C列（黄色填充的C列为预期结果），原VBA代码存在语法和逻辑错误，导致无法达到需求效果，具体问题和修正方案如下：

原代码的核心问题 #

• 变量赋值语法错误：Set BD As Range("A2","A6") 应为 Set BD = Range("A2:A6")；LR是长整型变量，无需Set关键字，正确写法为 LR = Cells(Rows.Count, "A").End(xlUp).Row
• Collection使用错误：未在处理新单元格前清空集合，且引用集合时写错变量名（col应为coll）
• 双层循环逻辑冗余：外层遍历A2:A6，内层又遍历所有行，会导致同一值被重复收集，结果出现重复内容
• 赋值时机错误：每次匹配就写入C列，而非收集完所有相同值后一次性写入

修正后的VBA代码 #

Sub MergeSameValues()
    Dim C As Range, BD As Range
    Dim i As Long, LR As Long
    Dim coll As Collection
    
    ' 获取A列最后一行行号，适配动态数据范围
    LR = Cells(Rows.Count, "A").End(xlUp).Row
    ' 定义需要处理的A列数据范围
    Set BD = Range("A2:A" & LR)
    
    ' 遍历每个A列单元格
    For Each C In BD
        ' 每次处理新单元格前，初始化空集合
        Set coll = New Collection
        ' 遍历所有行，收集相同A值对应的B列内容
        For i = 2 To LR
            If C.Value = Cells(i, "A").Value Then
                ' 添加内容到集合，Key参数+错误处理避免B列重复值被合并（不需要去重则删除On Error和Key部分）
                On Error Resume Next
                coll.Add Cells(i, "B").Value, Key:=CStr(Cells(i, "B").Value)
                On Error GoTo 0
            End If
        Next i
        
        ' 将集合内容转数组后合并写入C列
        If coll.Count > 0 Then
            Dim arr() As String
            ReDim arr(1 To coll.Count)
            For i = 1 To coll.Count
                arr(i) = coll(i)
            Next i
            C.Offset(0, 2).Value = Join(arr, ";")
        End If
    Next C
End Sub

关键逻辑说明 #

1. 动态数据范围：通过LR = Cells(Rows.Count, "A").End(xlUp).Row获取A列实际数据的最后一行，避免固定范围的局限性
2. 集合重置：处理每个A列单元格前新建Collection，防止之前的数据残留导致结果错误
3. 去重可选：添加Key参数和错误处理，可避免B列相同值被重复合并，不需要去重则可删除对应代码
4. 集合转数组合并：由于TextJoin无法直接读取Collection内容，先将集合转成数组，再用Join函数完成合并

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