标签：VBA
运行下面的VBA过程，将列出当前工作表中所有合并单元格的地址。程序会新建一个工作表并重命名，然后在其中输入所有合并单元格的地址。
详细代码：
代码语言：javascript复制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欢迎在下面留言，完善本文内容，让更多的人学到更完美的知识。
