Excel VBA含合并单元格排序：拆分、排序、合并方案求助

我明白你遇到的问题——合并单元格确实会直接阻断Excel的排序功能，不过按照你提出的三步走思路完全可以完美解决。下面是我整理的完整VBA代码，同时会逐段解释逻辑，方便你根据自己的表格调整：

Sub SortWithMergedCells()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim cell As Range
    Dim mergeArea As Range
    Dim i As Long
    Dim j As Long
    
    ' 设置目标工作表（可根据实际修改，比如Sheet1）
    Set ws = ThisWorkbook.ActiveSheet
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    
    ' --------------------------
    ' 步骤1：拆分合并单元格并填充值
    ' --------------------------
    ' 遍历所有单元格，处理合并区域
    For Each cell In ws.UsedRange
        If cell.MergeCells Then
            Set mergeArea = cell.MergeArea
            ' 取消合并
            mergeArea.UnMerge
            ' 将首个单元格的值复制到同区域所有单元格
            mergeArea.Value = cell.Value
        End If
    Next cell
    
    ' --------------------------
    ' 步骤2：按A列、C列升序排序
    ' --------------------------
    With ws.Sort
        .SortFields.Clear
        ' 主关键字：A列，升序
        .SortFields.Add Key:=ws.Range("A1:A" & lastRow), _
            SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        ' 次关键字：C列，升序
        .SortFields.Add Key:=ws.Range("C1:C" & lastRow), _
            SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        ' 设置排序范围（这里用UsedRange，可根据实际调整）
        .SetRange ws.UsedRange
        .Header = xlYes ' 如果你的表格有表头，设为xlYes；没有则设为xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
    ' --------------------------
    ' 步骤3：重新合并A、C列值均相同的单元格
    ' --------------------------
    ' 处理A列合并
    i = 2 ' 从第2行开始（假设第1行是表头）
    Do While i <= lastRow
        j = i
        ' 找到连续相同A列值的最后一行
        Do While j <= lastRow And ws.Cells(j, "A").Value = ws.Cells(i, "A").Value And _
            ws.Cells(j, "C").Value = ws.Cells(i, "C").Value
            j = j + 1
        Loop
        ' 如果有超过1行的相同值，合并A列单元格
        If j - i > 1 Then
            ws.Range(ws.Cells(i, "A"), ws.Cells(j - 1, "A")).Merge
        End If
        ' 处理C列合并
        If j - i > 1 Then
            ws.Range(ws.Cells(i, "C"), ws.Cells(j - 1, "C")).Merge
        End If
        i = j
    Loop
    
    MsgBox "排序和合并完成！", vbInformation
End Sub

代码细节说明 #

1. 拆分合并单元格 #

这段代码会遍历工作表的所有已使用单元格，一旦发现合并区域，就先取消合并，然后把区域内第一个单元格的值批量填充到所有单元格里——这样排序时每一行都有完整的关键字值，不会出现排序混乱。

2. 双列排序 #

这里用Excel的原生Sort对象，先按A列升序，再按C列升序。注意如果你的表格没有表头，记得把.Header = xlYes改成.Header = xlNo；如果需要调整排序范围，也可以把ws.UsedRange换成具体的单元格区域（比如ws.Range("A1:D" & lastRow)）。

3. 重新合并单元格 #

代码会从第2行开始（默认第1行是表头），逐行检查A列和C列的值是否和上一行完全相同，找到连续相同值的最大范围后，分别合并A列和C列对应的单元格。这样就能还原你需要的合并效果，同时保证排序后的结构正确。

注意事项 #

• 运行代码前建议先备份你的表格，避免意外数据丢失；
• 如果你的数据不在活动工作表，记得修改Set ws = ThisWorkbook.ActiveSheet为具体的工作表（比如Set ws = ThisWorkbook.Sheets("你的表名")）；
• 如果合并单元格不仅在A、C列，你可以参考步骤3的逻辑，扩展处理其他列。

内容的提问来源于stack exchange，提问作者user9663005