Sub全选合并单元格()
    Dim arr(), rng As Range, i As Byte, indexx As String, n As String
    For Each rng In ActiveSheet.UsedRange
      If rng.MergeCells Then   '如果具有合并属性
      If Split(rng.MergeArea.Address, ":")(0) <> indexx Then
                          '如果地址为合并单元格中第一个单元格地址
      ReDim Preserve arr(i)    '重定义数组
      arr(i)=rng.Address     '对数组赋值
      i=i+1              '循环/重复
      indexx=rng.Address
    End If
End If
Next
n=Join(arr, ",")
Range(n).Select         '选择合并单元格
End Sub

Split(expression[, delimiter[, limit[, compare]]])

Join(sourcearray[, delimiter])

Sub将所有合并单元格添加红色背景()
    Dim rng As Range
    For Each rng In ActiveSheet.UsedRange
      If rng.MergeCells Then
      If rng.Address=Split(rng.MergeArea.Address, ":")(0) Then rng.
        Interior.Color=65535
      End If
      Next
End Sub

Sub取消合并()
ActiveSheet.UsedRange.MergeCells=False
End Sub

Sub取得合并单元格的首个和末尾地址()
  MsgBox "单元格A1所在合并区域中" & Chr(10) & _
  "第一个单元格为：" & Split(Range("a1").MergeArea.Address, ":")(0) & Chr(10) _
  & "最末端单元格为：" & Split(Range("a1").MergeArea.Address, ":")(1), 64, "提示"
End Sub

Sub合并居中()
  Dim i%, counts%, sTem$
    Application.ScreenUpdating=False
Application.DisplayAlerts=False
Rng_count=Selection.Count
For i=1 To Rng_count
    sTem=sTem & Selection.Cells(i)
Next
With Selection
    .MergeCells=True
    .HorizontalAlignment=xlCenter
    .VerticalAlignment=xlCenter
    .NumberFormatLocal="@"
    .Value=sTem
End With
Application.DisplayAlerts=True
Application.ScreenUpdating=True
End Sub

Sub合并后粘贴()
    Dim temp As String, TD As New DataObject, rng As Range
    On Error GoTo err
    For Each rng In Selection
      temp=temp & rng.Value '合并区域中的数据
    Next rng
    TD.SetText temp '将合并的文本复制到DataObject
    TD.PutInClipboard  '将DataObject中的文本移到剪贴板上
    End
err:
    MsgBox "对不起，您选择的不是单元格！", 64, "提示"
End Sub

Sub批量合并单元格()
Application.DisplayAlerts=False                    '禁止提示
    For i=3 To Range("b65536").End(xlUp).Row Step 3'为变量i赋值，步长为3
      Range(Cells(i, 1), Cells(i+2, 1)).Merge        '合并
      Range(Cells(i, 1), Cells(i+2, 1)).HorizontalAlignment=xlCenter '居中
    Next
Application.DisplayAlerts=True
End Sub

Sub取消合并()
On Error GoTo err   '出错时运行“err”标签处的语句
    With Range(Cells(2, 1), Cells(Range("b65536").End(xlUp).Row, 1))
      .UnMerge                           '将A列数据取消合并
      .SpecialCells(xlCellTypeBlanks).Select  '选择空白单元格
      Selection.FormulaR1C1="=R[-1]C"      '输入公式
      .Value=.Value                     '将公式转为值
    End With
    [a1].Select: Exit Sub                  '退出程序，不运行下面的语句
err:
    MsgBox "区域中没有合并单元格！", 64, "提示"
End Sub

Sub取消合并方法二()
    For i=3 To Range("b65536").End(xlUp).Row Step 3
      Range(Cells(i, 1), Cells(i+2, 1)).UnMerge
      Range(Cells(i, 1), Cells(i+2, 1)).FillDown
    Next
End Sub

Sub取得合并单元格数目()
    Dim rng As Range, i As Byte
    Application.DisplayAlerts=False
    For Each rng In ActiveSheet.UsedRange  '遍历本表已用区域
      If rng.MergeCells Then  '如果单元格已合并
          If rng.Address=Split(rng.MergeArea.Address, ":")(0) Then
                i=i+1  '如果单元格是合并区域中第一个单元格，则累加计数器
      End If
    Next
    MsgBox "本表共有" & i & "个合并单元格!", 64, "单元格记数"
End Sub

Sub合并单元格地址()
Dim rng As Range, rg As Range, i As Byte
    For Each rng In ActiveSheet.UsedRange
    If rng.MergeCells Then
    If rng.Address=Split(rng.MergeArea.Address, ":")(0) Then
    If rg Is Nothing Then
      Set rg=rng
    Else
      Set rg=Application.Union(rg, rng)
    End If
      i=i+1
   End If
   End If
   Next
   MsgBox "合并单元格地址为：" & Chr(10) & rg.Address _
   & Chr(10) & "共有合并单元格" & i & "个!", 64, "提示"
End Sub

Sub对所有合并单元格添加批注并标示序数()
Dim rng As Range, i As Byte
Application.DisplayAlerts=False
For Each rng In ActiveSheet.UsedRange
  If rng.MergeCells Then
  If rng.Address=Split(rng.MergeArea.Address, ":")(0) Then
    rng.AddComment ("第" & i+1 & "个合并单元格!")
    rng.Comment.Shape.TextFrame.AutoSize=True
    rng.Comment.Visible=False
    i=i+1
  End If
  End If
  Next
End Sub

Sub将已用区域合并取消并让空白单元格等于原合并值()
    Dim rng As Range, val, cell As String
    For Each rng In ActiveSheet.UsedRange
    If rng.MergeCells Then
      cell=rng.MergeArea.Address
    val=rng.Value
    rng.UnMerge
    Range(cell).Value=val
End If
Next
End Sub