Excel VBA按两列批量分组异常：部分分组未生效求助

问题描述 #

需按B列（Epic）和E列（Feature）实现两级分组，要求每组保留首行作为表头，其余行折叠分组。当前代码部分生效，但Level 2（E列）的分组4未被正确分组。

截图说明 #

• 分组前：
  
• 分组后：
  

现有代码 #

Sub GroupByColBThenColE()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("Sheet1")

    Dim lastRow As Long
    lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row

    Dim startRow As Long, midRow As Long, endRow As Long
    Dim valB As Variant, valE As Variant

    startRow = 2 ' 假设表头在第1行

    Do While startRow <= lastRow
        valB = ws.Cells(startRow, "B").Value
        midRow = startRow

        ' 遍历所有同Epic（B列）的行
        Do While midRow <= lastRow And ws.Cells(midRow, "B").Value = valB
            valE = ws.Cells(midRow, "E").Value
            endRow = midRow

            ' 遍历同一Epic下所有同Feature（E列）的行
            Do While endRow + 1 <= lastRow _
                And ws.Cells(endRow + 1, "B").Value = valB _
                And ws.Cells(endRow + 1, "E").Value = valE
                endRow = endRow + 1
            Loop

            ' 对Feature层级的行分组（跳过首行）
            If endRow >= midRow + 1 Then
                ws.Rows((midRow + 1) & ":" & endRow).Group
            End If

            midRow = endRow + 1
        Loop

        ' 对Epic层级的行分组（跳过首行）
        If midRow - 1 >= startRow + 1 Then
            ws.Rows((startRow + 1) & ":" & (midRow - 1)).Group
        End If

        startRow = midRow
    Loop
End Sub

问题原因与修复方案 #

现有代码未清除旧分组，且未明确指定分组层级，导致单一行Feature的分组逻辑出现嵌套混乱。修复后的代码先清除所有残留分组，再按从内到外的顺序创建两级分组，确保层级关系正确。

修复后的代码 #

Sub GroupByColBThenColE_Fixed()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("Sheet1")
    Dim lastRow As Long, startRow As Long, midRow As Long, endRow As Long
    Dim valB As Variant, valE As Variant

    ' 清除所有现有分组，避免残留结构干扰
    ws.Cells.ClearOutline

    lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
    startRow = 2 ' 表头在第1行

    Do While startRow <= lastRow
        valB = ws.Cells(startRow, "B").Value
        midRow = startRow

        ' 遍历当前Epic下的所有行
        Do While midRow <= lastRow And ws.Cells(midRow, "B").Value = valB
            valE = ws.Cells(midRow, "E").Value
            endRow = midRow

            ' 找到当前Feature下的所有行
            Do While endRow + 1 <= lastRow _
                And ws.Cells(endRow + 1, "B").Value = valB _
                And ws.Cells(endRow + 1, "E").Value = valE
                endRow = endRow + 1
            Loop

            ' 对Feature的非首行分组（明确为Level 2）
            If endRow > midRow Then
                With ws.Rows((midRow + 1) & ":" & endRow)
                    .Group
                    .OutlineLevel = 2
                End With
            End If

            midRow = endRow + 1
        Loop

        ' 对Epic的非首行分组（明确为Level 1）
        If (midRow - 1) > startRow Then
            With ws.Rows((startRow + 1) & ":" & (midRow - 1))
                .Group
                .OutlineLevel = 1
            End With
        End If

        startRow = midRow
    Loop
End Sub

修改说明 #

1. 清除旧分组：添加ws.Cells.ClearOutline，确保每次分组前工作表无残留分组结构，避免层级混乱。
2. 明确分组层级：通过.OutlineLevel指定Feature分组为第2级、Epic分组为第1级，严格保证两级分组的嵌套关系。
3. 简化判断逻辑：将endRow >= midRow + 1简化为endRow > midRow，逻辑一致且更简洁。

修改后，每个Feature的首行都会被保留（即使仅1行），Epic分组会正确包裹其下所有非首行内容，完全符合“每组保留首行表头，其余行分组”的需求。

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