关于快速组级的应用案列

coldrolled

对于有层级表格，定义数字层级后，剩下的操作给简化一下（按列组级）
给大家分享两个功能：
1、组级
2、取消组级

1. Sub 组级()
   
2.     Dim R1%, C1%, H1%, H2%, K1%, k2%
   
3.     On Error Resume Next
   
4.     Err.Clear
   
5.     Set Sht1 = ActiveWorkbook.ActiveSheet
   
6.     If Err.Number <> 0 Then
   
7.         MsgBox "没有正打开的EXCEL文档"

复制代码

coldrolled

1. Sub 组级()
   
2.     Dim R1, C1, H1, H2, K1, k2 As Integer
   
3.     On Error Resume Next
   
4.     Err.Clear
   
5.     Set Sht1 = ActiveWorkbook.ActiveSheet
   
6.     If Err.Number <> 0 Then
   
7.         MsgBox "没有正打开的EXCEL文档"
   
8.         Exit Sub
   
9.     End If
   
10.     Err.Clear
    
11.     On Error GoTo 0
    
12.     R1 = ActiveCell.Row
    
13.     C1 = ActiveCell.Column
    
14.     H1 = Sht1.Range(Chr(64 + C1) & "65536").End(xlUp).Row
    
15.     On Error Resume Next
    
16.     Err.Clear
    
17.     K1 = CInt(Sht1.Cells(R1, C1))
    
18.     If Err.Number <> 0 Then
    
19.         MsgBox "请选中层级"
    
20.         Exit Sub
    
21.     End If
    
22.     Err.Clear
    
23.     On Error GoTo 0
    
24.     For i = R1 + 1 To H1
    
25.         k2 = CInt(Sht1.Cells(i, C1))
    
26.         If k2 = 0 Then
    
27.             Exit For
    
28.         ElseIf k2 <= K1 Then
    
29.             Exit For
    
30.         Else
    
31.             On Error Resume Next
    
32.             For K = 1 To k2 - K1
    
33.                 Rows(i).Group
    
34.             Next
    
35.             Err.Clear
    
36.             On Error GoTo 0
    
37.         End If
    
38.     Next
    
39.     Sht1.Outline.SummaryRow = xlAbove
    
40. End Sub
    
41. Sub 取消组级()
    
42.     For i = 1 To 8
    
43.         On Error Resume Next
    
44.         Cells.Rows.Ungroup
    
45.         On Error GoTo 0
    
46.     Next
    
47. End Sub

复制代码

coldrolled

这是运行效果图