'
' MergeSelectionCell Macro
' shxiande
' 时间: 2007-1-11
' 向下合并内容相同的单元格
'
'
Sub MergeSelectionCell()
Dim strTexta As String
Dim strTextn As String
Dim iRown As Integer
'关闭提示
Application.DisplayAlerts = False
'获得选定单元格的内容及位置
strTexta = Trim(ActiveCell.Text)
iRowa = ActiveCell.Row
iCola = ActiveCell.Column
'获得选定单元格下一行的内容
iRown = iRowa + 1
strTextn = Trim(Cells(iRown, iCola))
Do While strTextn = strTexta
iRown = iRown + 1
strTextn = Trim(Cells(iRown, iCola))
Loop
Range(Cells(iRowa, iCola), Cells(iRown - 1, iCola)).Select
'
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Merge
'打开提示
Application.DisplayAlerts = True
End Sub
