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

VBA EXCEL 专栏收录该内容
4 篇文章 0 订阅

合并需求

假如某一列包含多种重复单元,但是重复的单元对应的其它列却不相同,需求便是指定某一列,寻找其中相同的元素,对两行元素进行合并。如下图所示的源数据,
在这里插入图片描述
可以看到,该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

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

  • 1
    点赞
  • 1
    评论
  • 7
    收藏
  • 打赏
    打赏
  • 扫一扫,分享海报

评论 1 您还未登录,请先 登录 后发表或查看评论
©️2022 CSDN 皮肤主题:书香水墨 设计师:CSDN官方博客 返回首页

打赏作者

Volavion

你的鼓励将是我创作的最大动力

¥2 ¥4 ¥6 ¥10 ¥20
输入1-500的整数
余额支付 (余额:-- )
扫码支付
扫码支付:¥2
获取中
扫码支付

您的余额不足,请更换扫码支付或充值

打赏作者

实付
使用余额支付
点击重新获取
扫码支付
钱包余额 0

抵扣说明:

1.余额是钱包充值的虚拟货币,按照1:1的比例进行支付金额的抵扣。
2.余额无法直接购买下载,可以购买VIP、C币套餐、付费专栏及课程。

余额充值