轉別人的，但是忘記出處了

Sub SpecialMerge()

Dim M, N, i, j, k1, k2 As Long
Application.DisplayAlerts = False
k1 = 1
k2 = 1
With Selection
M = .Columns.Count
N = .Rows.Count
For j = 1 To M
For i = 1 To N
If .Cells(i, j) = "" Then
k2 = i
Else
Range(.Cells(k1, j), .Cells(k2, j)).Merge
k1 = i
k2 = i
End If
Next i
Range(.Cells(k1, j), .Cells(k2, j)).Merge
k1 = 1
k2 = 1
Next j
End With
Application.DisplayAlerts = True
End Sub