VBA 指定某列相同的内容合并，对应的其它列内容相加 |
您所在的位置：网站首页 › vba多条件求和代码 › VBA 指定某列相同的内容合并，对应的其它列内容相加 |
VBA 指定某列相同的内容合并，对应的其它列内容相加
|
合并需求
假如某一列包含多种重复单元，但是重复的单元对应的其它列却不相同，需求便是指定某一列，寻找其中相同的元素，对两行元素进行合并。如下图所示的源数据，
在这里提供一个可设定的解决方案，也是一个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 SubmergeCategoryValues主要就是满足了上述的多行合并需求。因为我在网络上所搜索到的程序大都有很多问题，而这个例程没有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希望该方法可以帮到你，有问题评论区见，我很快会回复。 |
可以看到，该Excel表格的A列有很多重复项，对他们进行合并，其它列直接连接起来，效果如下图所示。
【本文地址】
今日新闻 |
推荐新闻 |