如何自动建立分级显示

cmusic

参考了gouweicao78的帖子http://club.excelhome.net/thread-502272-1-1.html中的方法2，
但是还是需要逐一设公式，有没有更快的办法，数据量太大，要设上千个公式。
附件为一小部分数据。

mxqchina

手工太麻烦，关注一下，vba应该有办法

wc0606

1. '按照级别创建分组
   
2. Sub My_Group()
   
3.     Dim LastRow, my_group_i, my_group_j As Integer
   
4.     Dim i, j, m, my_data As Integer
   
5.    
   
6.     LastRow = ActiveSheet.UsedRange.Rows.Count
   
7.     LastColumn = ActiveSheet.UsedRange.Columns.Count
   
8.     LastColumn_E = Split(ActiveSheet.Cells(LastRow, LastColumn).Address, "[        DISCUZ_CODE_0        ]quot;)(1)
   
9.     Set myrange = Application.InputBox("请选择分组依据所在列和首行数据所在行的交叉单元格：", "Make by wangc", Default:="$A$3", Type:=8)
   
10.     my_group_i = myrange.Row
    
11.     my_group_j = myrange.Column
    
12.    
    
13.     my_data = my_group_i
    
14.     n = 0
    
15.    
    
16.     Application.ScreenUpdating = False
    
17.    
    
18.     ActiveSheet.UsedRange.ClearOutline
    
19.    
    
20.     ActiveSheet.Select
    
21.     Cells.Select
    
22.     With Selection.Interior
    
23.         .Pattern = xlNone
    
24.         .TintAndShade = 0
    
25.         .PatternTintAndShade = 0
    
26.     End With
    
27.    
    
28.     For i = my_data To LastRow Step 1
    
29.         If ActiveSheet.Cells(i, my_group_j).Value = "" Then
    
30.             GoTo tuichu
    
31.         End If
    
32. 
    
33.         If ActiveSheet.Cells(i, my_group_j).Value < 8 Then
    
34.             For j = i + 1 To LastRow Step 1
    
35. '                Debug.Print i
    
36.                 m = ActiveSheet.Cells(j, my_group_j).Value - ActiveSheet.Cells(i, my_group_j).Value
    
37.                 If m < -1 Then
    
38.                     m = -1
    
39.                 End If
    
40.                 If m > 1 Then
    
41.                     m = 1
    
42.                 End If
    
43.                
    
44.                 If j = LastRow And j - i >= 1 And m = 1 Then
    
45.                     ActiveSheet.Rows(i + 1 & ":" & j).Group
    
46.                     ActiveSheet.Range("A" & i & ":" & LastColumn_E & i).Interior.ThemeColor = xlThemeColorAccent6
    
47.                     ActiveSheet.Range("A" & i & ":" & LastColumn_E & i).Interior.TintAndShade = 0.799981688894314
    
48.                     Exit For
    
49.                 Else
    
50.                     Select Case m
    
51.                     Case 1
    
52.                         
    
53.                     Case 0
    
54.                         If j - i = 1 Then
    
55.                             Exit For
    
56.                         Else
    
57.                             ActiveSheet.Rows(i + 1 & ":" & j - 1).Group
    
58.                             ActiveSheet.Range("A" & i & ":" & LastColumn_E & i).Interior.ThemeColor = xlThemeColorAccent6
    
59.                             ActiveSheet.Range("A" & i & ":" & LastColumn_E & i).Interior.TintAndShade = 0.799981688894314
    
60.                             Exit For
    
61.                         End If
    
62.                     Case Else
    
63.                         If j - i = 1 Then
    
64.                             Exit For
    
65.                         Else
    
66.                             ActiveSheet.Rows(i + 1 & ":" & j - 1).Group
    
67.                             ActiveSheet.Range("A" & i & ":" & LastColumn_E & i).Interior.ThemeColor = xlThemeColorAccent6
    
68.                             ActiveSheet.Range("A" & i & ":" & LastColumn_E & i).Interior.TintAndShade = 0.799981688894314
    
69.                             Exit For
    
70.                         End If
    
71.                     End Select
    
72.                 End If
    
73.             Next j
    
74.         End If
    
75.     Next i
    
76.    
    
77.     With ActiveSheet.Outline
    
78.         .AutomaticStyles = False
    
79.         .SummaryRow = xlAbove
    
80.         .SummaryColumn = xlRight
    
81.     End With
    
82.    
    
83.     GoTo myok
    
84.    
    
85. tuichu:
    
86.     MsgBox "出错了!"
    
87. myok:
    
88.     ActiveSheet.Cells(1, 1).Select
    
89.     Application.ScreenUpdating = True
    
90. End Sub
    

复制代码

这里有个问题，没能解决，希望看到的高人帮忙解决下。http://club.excelhome.net/thread-1140921-1-1.html

wc0606

wc0606 发表于 2014-7-28 21:05
这里有个问题，没能解决，希望看到的高人帮忙解决下。http://club.excelhome.net/thread-1140921-1-1.html

品种码.rar (54.74 KB, 下载次数: 175)

2014-7-28 21:10 上传

点击文件名下载附件
代码

附上附件

yjh_27

按序号为分级显示自动创建组  按分级显示的组合自动编序号
http://club.excelhome.net/thread-1098513-1-1.html


9L 附件

zhouxiao

yjh_27 发表于 2014-7-29 13:56
按序号为分级显示自动创建组  按分级显示的组合自动编序号
http://club.excelhome.net/thread-1098513-1-1 ...

array数组中的-1,0,1,2,3这些数字让我感到疑惑,不是很理解.

yjh_27

zhouxiao 发表于 2014-7-30 09:30
array数组中的-1,0,1,2,3这些数字让我感到疑惑,不是很理解.

见 链接帖  11L