2011-11-30 58 views
1

我想在Excel中寫一個宏,這將允許我自動根據位於第一列中的編號進行分組。這是代碼。Excel中的分組深度級別是否存在限制?

Sub Makro1() 
Dim maxRow As Integer 
Dim row As Integer 
Dim groupRow As Integer 
Dim depth As Integer 
Dim currentDepth As Integer 

maxRow = Range("A65536").End(xlUp).row 

For row = 1 To maxRow 
    depth = Cells(row, 1).Value 
    groupRow = row + 1 
    currentDepth = Cells(groupRow, 1).Value 
    If depth >= currentDepth Then 
     GoTo EndForLoop 
    End If 
    Do While currentDepth > depth And groupRow <= maxRow 
     groupRow = groupRow + 1 
     currentDepth = Cells(groupRow, 1).Value 
    Loop 
    Rows(row + 1 & ":" & groupRow - 1).Select 
    Selection.Rows.Group 
EndForLoop: 
    Next row 
End Sub 

在Excel文件中的第一列是這樣的:

1 
2 
2 
3 
3 
4 
4 
4 
4 
5 
5 
5 
6 
6 
6 
6 
5 
6 
6 
6 
7 
8 
8 
9 
10 
9 
10 
10 
8 
7 
7 
8 
6 
5 
4 
3 
2 
1 
2 

當宏到達分組的深度8講,我得到錯誤編號1004。它看起來像Excel不允許我創建大於8的深度。有沒有解決方法?我正在使用MS Excel 2003.

回答

0

我寫了這個代碼像分組一樣隱藏子行。

它需要第一行爲空,其中將放置常規級按鈕。 它將爲每個節點創建一個按鈕(放置在第一列)。 點擊按鈕將隱藏/取消隱藏相應的子平面。

  • 的check_col是必須被填充到最後行的柱上進行(即沒有空行,或「while」循環將停止
  • 的lvl_col被包含級索引列
  • 該START_ROW是包含有用的數據

希望這有助於

Sub group_tree() 
check_col = "A" 
lvl_col = "D" 
start_row = 3 


Dim btn As Button 
Application.ScreenUpdating = False 
ActiveSheet.Buttons.Delete 

Dim t As Range 

'------------Place the buttons on top-------------- 
i = start_row 
e_lvl = 0 
b_spac = 0 
b_width = 20 
b_toggle = 0 
While Range(check_col & i) <> "" 
    lvl = Range(lvl_col & i) 
    If lvl > e_lvl Then e_lvl = lvl 
i = i + 1 
Wend 

Set t = ActiveSheet.Range("A" & 1) 
For c = Range(lvl_col & start_row) To e_lvl 
    Set btn = ActiveSheet.Buttons.Add(t.Left + b_spac, t.Top, b_width, 10) 
    With btn 
    .OnAction = "btnS_t" 
    .Caption = c 
    .Name = start_row & "_" & c & "_" & lvl_col & "_" & b_toggle 
    End With 
    b_spac = b_spac + 20 
Next 

'--------------Place the buttons at level--------- 

i = start_row 
While Range(check_col & i) <> "" 
    lvl = Range(lvl_col & i) 
    If Range(lvl_col & i + 1) > lvl Then 
    Set t = ActiveSheet.Range("A" & i) 
    ' Set btn = ActiveSheet.Buttons.Add(t.Left, t.Top, t.Width, t.Height) 
    Set btn = ActiveSheet.Buttons.Add(t.Left, t.Top, b_width, 10) 
    With btn 
     .OnAction = "btnS" 
     .Caption = lvl 
     .Name = i & "_" & lvl & "_" & lvl_col 
    End With 
    End If 
    i = i + 1 
Wend 
    Application.ScreenUpdating = True 
End Sub 

Sub btnS() 
    Dim but_r As Integer 
    Set b = ActiveSheet.Buttons(Application.Caller) 
    id_string = b.Name 

    Dim id() As String 
    id = Split(id_string, "_") 
    start_row = CInt(id(0)) 
    start_lvl = CInt(id(1)) 
    lvl_col = id(2) 

' MsgBox (lvl_col) 
    Call hide_rows(start_lvl, start_row, lvl_col) 
End Sub 

Sub hide_rows(start_lvl, start_row, lvl_col) 
    a = start_row + 1 
    While Range(lvl_col & a) > start_lvl 
    a = a + 1 
    Wend 

    If Range(lvl_col & start_row + 1, lvl_col & a - 1).EntireRow.Hidden = False Then 
    Range(lvl_col & start_row + 1, lvl_col & a - 1).EntireRow.Hidden = True 
    Else 
    Range(lvl_col & start_row + 1, lvl_col & a - 1).EntireRow.Hidden = False 
    End If 


End Sub 
Sub btnS_t() 
    Dim but_r As Integer 
    Set b = ActiveSheet.Buttons(Application.Caller) 
    id_string = b.Name 

    Dim id() As String 
    id = Split(id_string, "_") 
    start_row = CInt(id(0)) 
    start_lvl = CInt(id(1)) 
    lvl_col = id(2) 
    b_toggle = CInt(id(3)) 

    If b_toggle = 0 Then 
    b_toggle = 1 
    Else 
    b_toggle = 0 
    End If 

    b.Name = start_row & "_" & start_lvl & "_" & lvl_col & "_" & b_toggle 

    Call hide_rows_tot(start_lvl, start_row, lvl_col, b_toggle) 
End Sub 
Sub hide_rows_tot(start_lvl, start_row, lvl_col, b_toggle) 

    a = start_row 

    While Range(lvl_col & a) <> "" 
    b = a 
    While Range(lvl_col & b) > start_lvl 
    b = b + 1 
    Wend 

    If b > a Then 
    If b_toggle = 1 Then 
     Range(lvl_col & a, lvl_col & b - 1).EntireRow.Hidden = True 
    Else 
     Range(lvl_col & a, lvl_col & b - 1).EntireRow.Hidden = False 
    End If 

    a = b - 1 
    End If 
    a = a + 1 
    Wend 



End Sub 
第一行
相關問題