VBA程序：查找并列出指定工作表中所有合并单元格的地址

Sub FindandListMergedCells()
 Dim LastRow As Long
 Dim LastColumn As Integer
 Dim r As Long
 Dim c As Integer
 Dim counter As Integer
 Dim MySheet As String
 Dim NewSheet As String
 Dim MyAddr As String
 Application.ScreenUpdating = False
 '获取目标工作表数据
 LastRow = ActiveSheet.UsedRange.Rows(ActiveSheet.UsedRange.Rows.count).Row
 LastColumn = ActiveSheet.UsedRange.Columns(ActiveSheet.UsedRange.Columns.count).Column
 MySheet = ActiveSheet.Name
 '检查是否已存在与结果工作表名称相同的工作表
 On Error GoTo SafeToContinue
 Sheets(MySheet & "中的合并单元格").Select
 MsgBox "工作表 " & MySheet & "中的合并单元格" & " 已经存在! 请在运行这个程序前将该工作表删除或重命名."
 On Error GoTo 0
 Exit Sub
 ' 通过错误检查
SafeToContinue:
 ' 初始化打印行计数器
 counter = 2
 '  添加新工作表以保存结果
 Sheets.Add
 ActiveSheet.Name = MySheet & "中的合并单元格"
 NewSheet = ActiveSheet.Name
 Range("A1") = "合并单元格列表"
 ' 返回目标工作表
 Sheets(MySheet).Select
 '查找合并的单元格并将其地址写入新工作表
 For r = 1 To LastRow
   For c = 1 To LastColumn
     Cells(r, c).Select
     MyAddr = Selection.Address
     If Len(WorksheetFunction.Substitute(MyAddr, ":", "")) <> Len(MyAddr) Then
       Sheets(NewSheet).Cells(counter, 1) = MyAddr
       counter = counter + 1
     End If
   Next c
 Next r
 ' 删除重复地址并格式化结果
 Sheets(NewSheet).Select
 ' 将唯一地址复制到列C
 Application.CutCopyMode = False
 If counter > 3 Then
   Columns("A:A").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("C1"), _
     unique:=True
   ' 删除列A和列B
   Application.CutCopyMode = False
   Columns("A:B").Select
   Selection.Delete Shift:=xlToLeft
 End If
 ' 格式化新列A
 Range("A1").Select
 With Selection
   .HorizontalAlignment = xlCenter
   .VerticalAlignment = xlCenter
   .Interior.ColorIndex = 35
   .Font.Bold = True
 End With
 With Selection.Borders(xlEdgeLeft)
   .LineStyle = xlContinuous
   .Weight = xlThin
   .ColorIndex = xlAutomatic
 End With
 With Selection.Borders(xlEdgeTop)
   .LineStyle = xlContinuous
   .Weight = xlThin
   .ColorIndex = xlAutomatic
 End With
 With Selection.Borders(xlEdgeBottom)
   .LineStyle = xlContinuous
   .Weight = xlThin
   .ColorIndex = xlAutomatic
 End With
 With Selection.Borders(xlEdgeRight)
   .LineStyle = xlContinuous
   .Weight = xlThin
   .ColorIndex = xlAutomatic
 End With
 Columns("A:A").EntireColumn.AutoFit
 
 ' 以字母顺序排序地址
 Columns("A:A").Select
 Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlYes, _
   OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
 ' 显示结果
 Range("A1").Select
 On Error GoTo 0
 Application.ScreenUpdating = True
 If counter = 2 Then MsgBox "在工作表" & MySheet & " 中没有找到合并单元格."
End Sub