要求将下图所示的数据,部门相同的单元格按照部门合并。

VBA法
Sub 合并相同的单元格()
'变量声明
Dim strDep As String
Dim RowN As Long
Dim rng As Range
'获取第一行的部门信息
strDep = Cells(2, 1).Value
Set rng = Cells(2, 1)
'关闭警告提示
Application.DisplayAlerts = False
'循环遍历A列,从第2行至数据最后的下一行
For RowN = 2 To 26
If strDep = Cells(RowN, 1).Value Then
'部门相同,获取合并的单元格区域对象
Set rng = Union(rng, Cells(RowN, 1))
Else
'部门不同,进行合并单元格
rng.Merge
'重新获取部门信息
strDep = Cells(RowN, 1).Value
Set rng = Cells(RowN, 1)
End If
Next RowN
'开启警告提示
Application.DisplayAlerts = True
End Sub
合并后效果如下:

反向操作
Sub 拆分合并单元格()
Dim t As Variant
Dim strAddr
Dim c As Range
Dim r As Range
For Each r In Range("A2:A25")
If r.MergeCells Then
t = r.Value
strAddr = r.MergeArea.Address
r.UnMerge
End If
For Each c In Range(strAddr)
c.Value = t
Next
Next
End Sub
···
网友评论