ToToo

'
' 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