Mehrstufige Gruppierung per VBA
10.08.2004 23:53:37
Hartmut
vielleicht kann mir jemand beim Umbau eines Makros (von Bernd und Melanie)helfen, das ich auf folgender Seite entdeckt habe:
http://groups.google.de/groups?hl=de&lr=&ie=UTF-8&threadm=atadf8%24n6h%2402%241%40news.t-online.com&rnum=8&prev=/groups%3Fq%3Dgruppierung%2Bexcel%2Bvba%26hl%3Dde%26lr%3D%26ie%3DUTF-8%26sa%3DN%26tab%3Dwg
Mit Hilfe des dort beschriebenen Makros kann eine einstufige Gruppierung per VBA erzeugt werden. Die Gruppierung erfolgt in Abhängigkeit von der Ziffernlänge der Gruppierungsstufe nach der gruppiert werden soll. Kann mir jemand einen Tipp geben, wie ich dieses Makro umbauen muss, damit eine mehrstufige Gruppierung erfolgt. Beispiel:
1
11
111
1111
1112
1113
112
1121
1122
1123
...
1
12
121
1211
1212
1213
122
1221
1222
1223
..
Die Grupierung soll auf der ersten Stufe (1,..), auf der zweiten Stufe (11, ...) und auf der dritten Stufe (111,..) geschachtelt erfolgen.
Das o.g. Makro, das jedoch nur eine einstufige Gruppierungsebene zulässt lautet:
Sub Gruppieren_Melanie()
Dim Group_Beginn, Group_Ende
Dim lastRow As Long, i As Integer, Top As Byte
Top = Application.InputBox _
("Geben sie die Zeichenlänge der Gruppierungs-Überschriften an!" _
, "Gruppierung", "hier Zeichenlänge eingeben", , , , , 1)
If Top = False Then Exit Sub
Application.ScreenUpdating = False
Cells.ClearOutline
lastRow = Cells(Rows.Count, ActiveCell.Column).End(xlUp).Row
Do Until i + 1 >= lastRow
Columns(ActiveCell.Column).Font.Bold = False
i = i + 1
If Len(Cells(i, ActiveCell.Column)) = Top Then
Cells(i, ActiveCell.Column).Font.Bold = True
Group_Beginn = Cells(i + 1, ActiveCell.Column).Address
Do Until Len(Cells(i + 1, ActiveCell.Column)) = Top _
Or i >= lastRow
i = i + 1
Loop
Group_Ende = Cells(i, ActiveCell.Column).Address
Range(Group_Beginn, Group_Ende).Rows.Group
ActiveSheet.Rows(i).ShowDetail = False
End If
Loop
Application.ScreenUpdating = True
End Sub
Vielen Dank im Voraus. Ich hoffe, dass ich mein Problem einigermassen verständlich rüberbringen konnte.
Grüsse aus dem leicht verregneten Südbaden
Hartmut