关于快速自动进行创建组分级显示

keep2022

yjh_27 发表于 2024-8-12 14:27
看懂模块1即可。模块2、模块3是二个自定义函数（过程）。
模块2是识别级别，
模块3是创建分组。

万分感谢~~~~~

ynzsvt

1. Sub 根据关键词分级显示()
   
2. Dim St$
   
3. ActiveSheet.Cells.ClearOutline
   
4. ActiveSheet.Outline.SummaryRow = xlAbove
   
5. s0 = 5
   
6. s1 = Cells(Rows.Count, 1).End(xlUp).Row
   
7. 
   
8. VbaSpeed False
   
9. j = 4
   
10. Range(Cells(s0 + 1, j), Cells(s1, j)).Rows.Group
    
11. Range(Cells(s0 + 1, j), Cells(s1, j)).Rows.Group
    
12. Range(Cells(s0 + 1, j), Cells(s1, j)).Rows.Group
    
13. Range(Cells(s0 + 1, j), Cells(s1, j)).Rows.Group
    
14. Range(Cells(s0 + 1, j), Cells(s1, j)).Rows.Group
    
15. Range(Cells(s0 + 1, j), Cells(s1, j)).Rows.Group
    
16. 
    
17. For i = s0 + 1 To s1
    
18.   St = Cells(i, j)
    
19.   If St = "事项" Then
    
20.    UnGroupAt i, j, 6
    
21.   ElseIf St = "分部" Then
    
22.    UnGroupAt i, j, 5
    
23.   ElseIf St <> "" Then
    
24.    UnGroupAt i, j, 4
    
25.   End If
    
26. Next i
    
27. 
    
28. j = 5
    
29. For i = s0 + 1 To s1
    
30.   St = Cells(i, j)
    
31.   If St = "事项" Then
    
32.    UnGroupAt i, j, 3
    
33.   ElseIf St = "小计" Then
    
34.    UnGroupAt i, j, 2
    
35.   ElseIf St = "分计" Then
    
36.    UnGroupAt i, j, 1
    
37.   End If
    
38. Next i
    
39. 
    
40. VbaSpeed True
    
41. End Sub
    
42. 
    
43. Sub UnGroupAt(ByVal i&, ByVal j&, ByVal k&)
    
44. For l = 1 To k
    
45.   Cells(i, j).EntireRow.Ungroup
    
46. Next l
    
47. End Sub

复制代码