大家好，今天和大家分享的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
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
'用户选择单元格区域的开始列
For i = 1 To UBound(brr)
If brr(i, 2) > 0 Then
For j = 1 To UBound(arr, 2)
Set rngMerge = Cells(i + lngRowFirst - 1, lngClnFirst + j - 1)
rngMerge.Resize(brr(i, 2) + 1, 1).Merge
Next
End If
Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
rngSelect.Select
End Sub
硬核VBA经典代码应用大全
淘宝、京东、当当各大商城均有销售
详情点击【阅读原文】
|
|
转播
