如何修改VBA代码将合并单元格数组改为垂直排序？

原代码通过For Each遍历单元格时，Excel默认采用行优先顺序（先遍历一行的所有列，再进入下一行），因此得到的地址是水平排列（如A1、B1、C1...）。要改为垂直顺序（列优先，如A1、A2、A3...），需要调整遍历逻辑为列优先，同时修正原代码重复记录合并区域的问题。

修改后的完整代码 #

Sub GetSelectedMergedCells()
    Dim selRange As Range
    Dim mergedCells As Range
    Dim i As Integer
    Dim cellArray() As Variant
    Dim ws As Worksheet
    Dim outputRange As Range
    Dim r As Long, c As Long ' 行、列循环变量
    
    Set selRange = ActiveSheet.UsedRange
    i = 0
    
    ' 列优先遍历：先循环列，再循环行
    For c = 1 To selRange.Columns.Count
        For r = 1 To selRange.Rows.Count
            Set mergedCells = selRange.Cells(r, c)
            If mergedCells.MergeCells Then
                ' 仅记录合并区域的左上角单元格，避免重复存储同一合并区域
                If mergedCells.Address = mergedCells.MergeArea.Cells(1, 1).Address Then
                    ReDim Preserve cellArray(i)
                    ' 如需存储合并区域完整地址，用mergedCells.MergeArea.Address
                    ' 如需仅存储左上角单元格地址，用mergedCells.Address
                    cellArray(i) = mergedCells.Address
                    i = i + 1
                End If
            End If
        Next r
    Next c
    
    ' 写入结果到新工作表
    Set ws = ThisWorkbook.Worksheets.Add
    If i > 0 Then
        Set outputRange = ws.Range("A1").Resize(i, 1)
        outputRange.Value = WorksheetFunction.Transpose(cellArray)
        ws.Columns.AutoFit
        
        MsgBox "找到以下 " & i & " 个合并单元格:" & vbCrLf & Join(cellArray, vbCrLf)
    Else
        MsgBox "未找到合并单元格。"
    End If
End Sub

关键修改说明 #

1. 列优先遍历逻辑：
   替换原For Each循环为嵌套循环，外层循环列（c）、内层循环行（r），确保先遍历完一列的所有行，再进入下一列，实现垂直顺序的地址收集。

2. 避免重复记录合并区域：
   原代码会将合并区域内的每个单元格都存入数组（比如A1:A3合并会存3次A1地址），新增判断mergedCells.Address = mergedCells.MergeArea.Cells(1,1).Address，仅当单元格是合并区域的左上角时才记录，避免冗余数据。

3. 地址存储选项：
   代码中默认存储合并区域左上角的单个单元格地址（如A1），如果需要存储整个合并区域的完整地址（如$A$1:$A$3），只需将cellArray(i) = mergedCells.Address改为cellArray(i) = mergedCells.MergeArea.Address。

内容的提问来源于stack exchange，提问作者HADY-DAR