VB实现excel的层级折叠-洪萨配资

主要记录一下使用入栈&出栈的方式，记录下excel的内容折叠公式，代码的实现不重要。重要的是解决问题的思路

这个算法中创建分组的时机是：当需要闭合一个分组时，且该分组包含多行内容。

具体触发条件

1.基本规则

创建分组发生在Do While循环中，当检测到当前层级 ≤ 栈顶层级时：

If currentLevel <= levelStack(stackPtr) Then ' 结束前一个分组 startRow = rowStack(stackPtr) + 1 ' 分组开始行 endRow = i - 1 ' 分组结束行 ' 关键判断：只有多于一行才创建分组 If endRow >= startRow Then ws.Rows(startRow & ":" & endRow).Group ' 创建分组 End If stackPtr = stackPtr - 1 ' 出栈 End If

2.何时真正创建分组（举例说明）

情况1：需要创建分组（多行内容）

层级：1, 2, 2, 1 行号：3, 4, 5, 6 处理到行6（层级1）时： - 栈中：行4(2), 行3(1) - 当前层级=1，栈顶层级=2 → 创建行4-5的分组 - 继续：当前层级=1，栈顶层级=1 → 创建行4-5的分组

情况2：不创建分组（单行内容）

层级：1, 2, 1 行号：3, 4, 5 处理到行5（层级1）时： - 栈中：行4(2), 行3(1) - 当前层级=1，栈顶层级=2 → startRow=5, endRow=4 → 不创建分组 - 继续：当前层级=1，栈顶层级=1 → startRow=4, endRow=4 → 不创建分组

为什么这样设计？

原因1：避免单行分组

Excel分组通常用于折叠/展开多行内容，单行分组没有实际意义：

' 如果分组只有一行，不创建分组 If endRow >= startRow Then ws.Rows(startRow & ":" & endRow).Group End If

这里endRow >= startRow保证了至少有两行。

原因2：自然的分组闭合

创建分组的时机是发现分组结束时：

分组开始：当遇到一个层级数字时，它可能是新分组的开始（入栈）
分组结束：当遇到相同或更高层级时，前一个分组结束

原因3：嵌套分组的需要

为了正确嵌套，必须在发现子分组结束后才创建父分组：

层级：1, 2, 3, 3, 2, 1 ↑ ↑ 入栈 创建分组

实际例子详解

示例1：创建分组

行号 | 层级 3 | 1 ← 入栈(3,1) 4 | 2 ← 入栈(4,2) 5 | 2 ← 当前层级=2，栈顶=2 → 分组4-4？(单行不创建) 6 | 1 ← 当前层级=1，栈顶=2 → 分组5-5？(单行不创建) 栈顶=1 → 分组4-5 ✓ (多行，创建)

示例2：不创建分组

行号 | 层级 3 | 1 ← 入栈 4 | 1 ← 当前层级=1，栈顶=1 → 分组4-3？(单行不创建)

特殊情况处理

情况1：连续相同层级

层级：1, 2, 2, 2, 1 行号：3, 4, 5, 6, 7 处理过程： - 行5: 层级2，栈顶=2 → 分组4-4？(单行不创建) - 行6: 层级2，栈顶=2 → 分组5-5？(单行不创建) - 行7: 层级1，栈顶=2 → 分组6-6？(单行不创建) 栈顶=1 → 分组4-6 ✓ (多行，创建)

情况2：跳级

层级：1, 3, 2, 1 行号：3, 4, 5, 6 处理过程： - 行5: 层级2，栈顶=3 → 分组4-4？(单行不创建) - 行6: 层级1，栈顶=2 → 分组5-5？(单行不创建) 栈顶=3 → 分组4-5 ✓ (多行，创建) 栈顶=1 → 分组4-5 ✓ (多行，创建) 注意：这里会创建两个重叠的分组

代码的逻辑总结

入栈时机：每读取一行，就将其入栈，作为可能的分组开始
创建分组时机：当遇到层级 ≤ 栈顶层级时，表示前一个分组结束
分组范围：从栈顶行号+1到当前行号-1
过滤条件：只有范围包含多行时才创建分组

可视化理解

层级：1 2 3 3 2 1 | | | | | | 分组： |---------| ← 创建分组(当遇到层级2时) |----| ← 创建分组(当遇到层级3时) |----| ← 不创建(单行) |-------------------| ← 创建分组(当遇到层级1时)

关键点记忆

创建分组 = 发现分组结束 + 分组有多行
分组结束信号：当前层级 ≤ 栈顶层级
分组多行判断：结束行 ≥ 开始行

这样设计的算法能够智能地：

为多行内容创建分组
避免为单行创建无意义的分组
正确处理嵌套关系
高效利用栈来跟踪分组状态

Sub CreateHierarchicalFold()
Dim ws As Worksheet
Dim lastRow As Long, i As Long, j As Long
Dim startRow As Long, endRow As Long
Dim currentLevel As Integer, prevLevel As Integer
Dim maxLevel As Integer
Dim colorArr(1 To 8) As Long
Dim rowStack() As Long
Dim levelStack() As Integer
Dim stackPtr As Long

' 设置工作表 Set ws = ActiveSheet lastRow = ws.Cells(ws.Rows.count, "H").End(xlUp).Row ' 检查数据是否从第3行开始 If lastRow < 3 Then MsgBox "数据不足，请确保数据从第3行开始且至少有一行数据", vbExclamation Exit Sub End If ' 定义颜色数组 colorArr(1) = RGB(219, 238, 243) ' 层级1 - 浅蓝色 colorArr(2) = RGB(235, 241, 222) ' 层级2 - 浅绿色 colorArr(3) = RGB(255, 242, 204) ' 层级3 - 浅黄色 colorArr(4) = RGB(248, 203, 173) ' 层级4 - 浅橙色 colorArr(5) = RGB(245, 215, 230) ' 层级5 - 浅粉色 colorArr(6) = RGB(226, 239, 218) ' 层级6 - 浅青绿 colorArr(7) = RGB(255, 235, 238) ' 层级7 - 浅红色 colorArr(8) = RGB(237, 231, 246) ' 层级8 - 浅紫色 ' 清除现有的分组和格式 'ws.ClearOutline ws.Range("A3:Z" & lastRow).Interior.ColorIndex = xlNone ' 查找数据区域的最大列 Dim lastCol As Long lastCol = ws.Cells(1, ws.Columns.count).End(xlToLeft).Column ' 第一步：为每行设置背景颜色 For i = 3 To lastRow If IsNumeric(ws.Cells(i, "H").value) Then currentLevel = CInt(ws.Cells(i, "H").value) ' 确保层级在合理范围内 If currentLevel < 1 Then currentLevel = 1 If currentLevel > 8 Then currentLevel = ((currentLevel - 1) Mod 8) + 1 ' 设置背景颜色 ws.Range(ws.Cells(i, "A"), ws.Cells(i, lastCol)).Interior.Color = colorArr(currentLevel) End If Next i ' 初始化栈 ReDim rowStack(1 To lastRow) ReDim levelStack(1 To lastRow) stackPtr = 0 ' 第二步：使用栈算法创建正确的嵌套分组 For i = 3 To lastRow ' 获取当前行的层级 If IsNumeric(ws.Cells(i, "H").value) Then currentLevel = CInt(ws.Cells(i, "H").value) Else currentLevel = 1 End If ' 如果当前层级小于等于栈顶层级，结束前一个分组 Do While stackPtr > 0 If currentLevel <= levelStack(stackPtr) Then ' 结束前一个分组 startRow = rowStack(stackPtr) + 1 endRow = i - 1 ' 如果分组有内容（多行），则创建分组 If endRow >= startRow Then ws.Rows(startRow & ":" & endRow).Group End If stackPtr = stackPtr - 1 Else Exit Do End If Loop ' 将当前行压入栈 stackPtr = stackPtr + 1 rowStack(stackPtr) = i levelStack(stackPtr) = currentLevel Next i ' 处理栈中剩余的分组 Do While stackPtr > 0 startRow = rowStack(stackPtr) + 1 endRow = lastRow If endRow >= startRow Then ws.Rows(startRow & ":" & endRow).Group End If stackPtr = stackPtr - 1 Loop ' 第三步：折叠所有分组（显示最高层级） ws.Outline.ShowLevels RowLevels:=1 ' 自动调整列宽 ws.Columns.AutoFit MsgBox "层级折叠已创建完成！" & vbCrLf & _ "已处理 " & lastRow - 2 & " 行数据。" & vbCrLf & _ "点击左侧的加减号可以展开/折叠不同层级。", vbInformation

End Sub