VBA 指定某列相同的内容合并，对应的其它列内容相加

合并需求

假如某一列包含多种重复单元，但是重复的单元对应的其它列却不相同，需求便是指定某一列，寻找其中相同的元素，对两行元素进行合并。如下图所示的源数据，

可以看到，该Excel表格的A列有很多重复项，对他们进行合并，其它列直接连接起来，效果如下图所示。

解决方案

在这里提供一个可设定的解决方案，也是一个SUB子程序。源代码如下。

Sub mergeCategoryValues()
    Dim lngRow As Long

    With ActiveSheet
        Dim columnToMatch As Integer: columnToMatch = 1       'Indicates the column to Match
        Dim columnToConcatenateDown As Integer: columnToConcatenateDown = 2   'Indicates the up column to Concatenate
        Dim columnToConcatenateUp As Integer: columnToConcatenateUp = 6         'Indicates the down column to Concatenate
        lngRow = .Cells(Rows.Count, columnToMatch).End(xlUp).Row      'Calculate the Rownum of last line
        .Cells(columnToMatch).CurrentRegion.Sort key1:=.Cells(columnToMatch), Header:=xlYes     'Sort the column to match in order to make the same value appear at the same time

        Do
            If .Cells(lngRow, columnToMatch) = .Cells(lngRow - 1, columnToMatch) Then           'If this line equals to next line of this line
                For i = columnToConcatenateDown To columnToConcatenateUp                        'Concatenate column by column
                    .Cells(lngRow - 1, i) = .Cells(lngRow - 1, i) & Chr(10) & .Cells(lngRow, i)
                Next i
                .Rows(lngRow).Delete                                        'Delete the Row which has been copied
            End If
            lngRow = lngRow - 1                                         'From last to first
        Loop Until lngRow = 1                                           'Until to first
    End With
End Sub

mergeCategoryValues主要就是满足了上述的多行合并需求。因为我在网络上所搜索到的程序大都有很多问题，而这个例程没有BUG，而且会有很详细的代码注释，可以帮助你们进行二次开发。中文代码注释如下：

Sub mergeCategoryValues()
    Dim lngRow As Long
    With ActiveSheet
        Dim columnToMatch As Integer: columnToMatch = 1       'Indicates the column to Match 选择匹配列
        Dim columnToConcatenateDown As Integer: columnToConcatenateDown = 2   'Indicates the up column to Concatenate 选择想要连接的左列 
        Dim columnToConcatenateUp As Integer: columnToConcatenateUp = 6         'Indicates the down column to Concatenate 选择想要连接的右列，例如我要匹配第一列，对应相同元素的第二列到第五列进行连接 那么 columnToConcatenateDown = 2， columnToConcatenateUp = 5
        lngRow = .Cells(Rows.Count, columnToMatch).End(xlUp).Row      'Calculate the Rownum of last line 计算指定匹配列的最后一行的行数
        .Cells(columnToMatch).CurrentRegion.Sort key1:=.Cells(columnToMatch), Header:=xlYes     'Sort the column to match in order to make the same value appear at the same time 对匹配列进行排序，使得相同的元素得以同时出现

        Do
            If .Cells(lngRow, columnToMatch) = .Cells(lngRow - 1, columnToMatch) Then           'If this line equals to next line of this line 如果匹配列两个相邻元素相等，那么触发合并程序
                For i = columnToConcatenateDown To columnToConcatenateUp                        'Concatenate column by column 对连接列进行遍历
                    .Cells(lngRow - 1, i) = .Cells(lngRow - 1, i) & Chr(10) & .Cells(lngRow, i)   '进行连接，并使用Chr（10）作为分隔符
                Next i
                .Rows(lngRow).Delete                                        'Delete the Row which has been copied 删除已经被合并的列
            End If
            lngRow = lngRow - 1                                         'From last to first
        Loop Until lngRow = 1                                           'Until to first
    End With
End Sub

希望该方法可以帮到你，有问题评论区见，我很快会回复。