大家晚上好，今天和大家分享的VBA代码是……
批量合并相同值单元格
很久以前，我们和大家分享过一段类似功能的代码，链接：【Excel VBA】批量合并相同值单元格
但那段代码只支持单列数据合并……
另外，在那段推文的结尾，我们也留了一个尾巴。尾巴里说使用数组的方法，批量合并效率会高于遍历单元格两两合并……
打个响指，欠揍脸，我们今天和大家分享的方法就是数组法的啦。
效果动画如下：
![]()
小贴士：
1，该段代码支持用户选择单列或多列数据，选择区域的整行数据相同则进行合并。
2，代码照例允许用户选择整列数据，也不用担心运算量过大，系统假死的情况。
3，代码使用了一个数组brr用于存放数据以及合并单元格的行数。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
淘宝、当当、京东各大网店均有销售
|
|
转播
