vba求助，已有狭义合并代码，求相似行智能批量广义合并代码！！！

youxianwei

vba求助，已有狭义合并代码，求相似行智能批量广义合并代码！！！，【半百】的代码只能正确执行一次，第二次重复执行会将主列不重复的单元格误删，求大家继续改进。

youxianwei

excel home 论坛已有高手解答，特此分享~

Option Explicit

Sub test()

    Dim A, B, d, i%, j%, s, x, 公式变量
   
    Sheets(1).Select
   
    公式变量 = Range("e3").Formula
   
    A = Range("a2:m" & Range("a65536").End(xlUp).Row)  '''''''''''''''必须是a2，a3则第3行不识别
   
    ReDim B(1 To UBound(A), 1 To UBound(A, 2))
    Set d = CreateObject("scripting.dictionary")
    For i = 2 To UBound(A)
        x = A(i, 5)    'key
        If x <> "" Then
            If d.exists(x) Then
                '已存在
                For j = 6 To UBound(A, 2)
                    B(d(x), j) = IIf(B(d(x), j) = "", A(i, j), B(d(x), j) & IIf(A(i, j) = "", "", "，" & A(i, j)))      '''''''第二次执行会误删！！！！！
                Next j
            Else
                '不存在
                s = s + 1: d(x) = s
                For j = 1 To UBound(A, 2)
                    B(s, j) = A(i, j)
                Next j
            End If
        End If
    Next i

    Sheets(2).Select
    Sheets(2).Range("a3:z1000").Clear
    [a3].Resize(s, UBound(B, 2)) = B
   
   
    Range("e3") = 公式变量
    Range("e3").Resize(Range("e65536").End(xlUp).Row).FillDown
   
End Sub