【ExcelVBA】如何批量合并相同值单元格？
批量合并相同值单元格
很久以前，我们和⼤家分享过⼀段类似功能的代码，链接：【Excel VBA】批量合并相同值单元
格
但那段代码只⽀持单列数据合并……
另外，在那段推⽂的结尾，我们也留了⼀个尾巴。尾巴⾥说使⽤数组的⽅法，批量合并效率会
⾼于遍历单元格两两合并……
打个响指，⽋揍脸，我们今天和⼤家分享的⽅法就是数组法的啦。
效果动画如下：
⼩贴⼠：
1，该段代码⽀持⽤户选择单列或多列数据，选择区域的整⾏数据相同则进⾏合并。
2，代码照例允许⽤户选择整列数据，也不⽤担⼼运算量过⼤，系统假死的情况。
3，代码使⽤了⼀个数组brr⽤于存放数据以及合并单元格的⾏数。VBA在使⽤数组处理数据时，
这个⽅法是经常使⽤到的。如果你函数还可以，那么你可以把这样的数组理解为辅助列。对于
vba 字符串转数组函数⼤神，⽐如曾经的我，可能相当讨厌辅助列，认为不够表现⾼超的⽔平；但是，在VBA
中，善于使⽤辅助列性质的数组不但是个好习惯，⽽且经常是解决问题的最好⽅法，任性的不
加之⼀。
4，事实上这段代码也可以不使⽤数组brr，⽽只使⽤变量……
5，我们下期再分享如何批量撤销合并单元格。
晚安，晚安，晚安……
代码如下：
Sub RngMergeCondition() '批量合并单元格    Dim rngUser As Range    Dim rngMerge As Range    Dim rngSelect As Range    Dim i As Long, j As Long    Dim lngRowFirst As Long
Dim lngClnFirst As Long    Dim arr As Variant    Dim brr As Variant    Dim strTemp As String  Dim lngBK As Long    Dim shtUser As Worksheet    On Error Resume Next    Set rngSelect = Selection    Set rngUser = Application.InputBox('请选择需要合并的单元格区域！',
Default:=rngSelect.Address, Type:=8)    Set rngUser = Intersect(rngUser.Parent.UsedRange, rngUser)    '使⽤Intersect规避⽤户选择整列数据    If rngUser Is Nothing Then MsgBox '选择的单
元格区域不能为空⽩': Exit Sub    arr = rngUser.Value    ReDim brr(1 To UBound(arr), 1 To 2)
'结果数组，第⼀列保存值，第⼆列保存合并⾏数    For i = 1 To UBound(arr)        strTemp = ''      For j = 1 To UBound(arr, 2)            strTemp = strTemp & '@@' & arr(i, j)            '合并多列字符串
为单个字符串        Next        brr(i, 1) = strTemp        '字符串装⼊结果数组        If i > 1 Then        '如
果不是第⼀⾏            If brr(i - 1, 1) = strTemp Then                If lngBK = 0 Then lngBK = i -
1                'lngBK变量赋值结果数组⽤于存放合并⾏数的位置                brr(lngBK, 2) = brr(lngBK,
2) + 1                '累计相同值的⾏数            Else                lngBK = i            End If        End If    Next  Application.ScreenUpdating = False    Application.DisplayAlerts = False    lngRowFirst = rngUser.Row    '⽤户选择单元格区域的开始⾏    lngClnFirst = rngUser.Column    '⽤户选择单元
格区域的开始列    Set shtUser = rngUser.Parent    For i = 1 To UBound(brr)        If brr(i, 2) > 0 Then            For j = 1 To UBound(arr, 2)                Set rngMerge = shtUser.Cells(i + lngRowFirst -1, lngClnFirst + j - 1)                rngMerge.Resize(brr(i, 2) + 1, 1).Merge            Next        End If  Next    Application.ScreenUpdating = True    Application.DisplayAlerts = TrueEnd Sub
淘宝、当当、京东各⼤⽹店均有销售

版权声明：本站内容均来自互联网，仅供演示用，请勿用于商业和其他非法用途。如果侵犯了您的权益请与我们联系QQ:729038198，我们将在24小时内删除。