Sub MergeCells()
Dim i, j As Long
Dim cell As Range
Dim intMinRow, intMaxRow As Long
Dim intMinCol, intMaxCol As Long
Dim strMergeValue As String
Dim objMergeArea As Range
Dim rng As Range
If TypeName(Selection) <> "Range" Then Exit Sub
Set rng = Intersect(ActiveSheet.UsedRange, Selection)
If rng Is Nothing Then Exit Sub
intMinRow = rng.Cells(1, 1).Row
intMaxRow = rng.Cells(rng.Cells.Count).Row
intMinCol = rng.Cells(1, 1).Column
intMaxCol = rng.Cells(rng.Cells.Count).Column
Application.DisplayAlerts = False
Set rng = Intersect(ActiveSheet.UsedRange, rng)
For j = intMinCol To intMaxCol
For i = intMaxRow To intMinRow Step -1
Set cell = Cells(i, j)
If cell.Value <> "" And cell.Offset(1, 0).Value = cell.Value Then
cell.Resize(2, 1).Merge
End If
Next i
Next j
Application.DisplayAlerts = True
'MsgBox "Done."
MessageBoxTimeout 0, "Done.", "Merge Cells", 0, 1, 500
End Sub
2. 取消合并单元格
Sub UnmergeCells()
Dim i, j As Long
Dim cell As Range
Dim intMinRow, intMaxRow As Long
Dim intMinCol, intMaxCol As Long
Dim strMergeValue As String
Dim objMergeArea As Range
Dim rng As Range
If TypeName(Selection) <> "Range" Then Exit Sub
Set rng = Intersect(ActiveSheet.UsedRange, Selection)
If rng Is Nothing Then Exit Sub
intMinRow = rng.Cells(1, 1).Row
intMaxRow = rng.Cells(rng.Cells.Count).Row
intMinCol = rng.Cells(1, 1).Column
intMaxCol = rng.Cells(rng.Cells.Count).Column
For i = intMinRow To intMaxRow
For j = intMinCol To intMaxCol
Set cell = Cells(i, j)
strMergeValue = cell.MergeArea.Cells(1, 1).Value
Set objMergeArea = Range(cell.MergeArea.Address)
objMergeArea.MergeCells = False
For Each rng In objMergeArea
rng.Value = strMergeValue
'rng.VerticalAlignment = xlCenter
'rng.HorizontalAlignment = xlLeft
Next
Next j
Next i
'MsgBox "Done."
MessageBoxTimeout 0, "Done.", "Unmerge Cells", 0, 1, 500
End Sub