Live-Forum - Die aktuellen Beiträge
Datum
Titel
18.04.2024 21:09:11
4 Spalten aus smarter Tabelle in andere smarte Tab. kopieren
18.04.2024 20:45:35
Worksheet_Activate für alle Sheets
18.04.2024 19:30:20
VBA - Tabelle mit Mannschaftsergebnissen sortieren
18.04.2024 18:04:29
Formel fehler Wert#
Du findest keine passende Antwort auf Deine Frage?
Stelle Deine Frage in unserem Live-Forum
Anzeige
Archiv - Navigation
1316to1320
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Vorheriger Thread
Vorheriger Thread
Rückwärts Blättern
1316to1320
1316to1320
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Nächster Thread
Nächster Thread
Vorwärts blättern
Inhaltsverzeichnis

Hierarchische Gruppierung mit VBA

Hierarchische Gruppierung mit VBA
10.06.2013 14:12:58
Jürgen
Hallo Liebe Experten,
Ich benötige ein Macro mit dem ich die folgenden Werte in Spalte "A" hierarchisch gruppieren kann. Ich habe schon einige Versuche unternommen, aber es hat bisher noch nichts vollständig funktioniert.
1
1.1
1.1.1
1.1.1.1
1.1.1.1.1
1.1.1.1.1.1
1.1.1.1.1.2
1.1.1.1.1.3
1.1.2
1.1.2.1
1.1.2.1.1
1.1.2.1.1.1
1.1.2.1.1.2
1.2
usw.
Vielen Dank schon mal für die dringend benötigte Hilfe!
Jürgen

17
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
Bahnhof
10.06.2013 14:38:27
Klaus
Hallo Jürgen,
ich habe keine Ahnung, was du mit "hierachischer Gruppierung" meinst. Lad doch mal eine Musterdatei hoch, vielleicht wirds dann klarer?
Grüße,
Klaus M.vdT.

AW: Bahnhof
10.06.2013 15:10:17
Klaus
Hallo Jürgen,
wenn ich dich richtig verstanden habe, dann so:
Option Explicit
Sub GruppiereAutomatisch()
Const ColUrsprung As Integer = 1 'die Hierachie-Ebene ensteht in Spalte A = 1
Dim iRow As Long
Dim i As Integer
Dim rMaster As Range
Dim rSlave As Range
With ActiveSheet
'alle Gruppen aufheben
On Error Resume Next
For i = 1 To 8
.Cells.Rows.Ungroup
Next i
On Error GoTo 0
iRow = .Cells(.Rows.Count, ColUrsprung).End(xlUp).Row
'jede Zelle als "Master" durchlaufen"
For Each rMaster In .Range("A3:A" & iRow)
'für jede "Master" Zelle die Endzelle finden
For Each rSlave In .Range(.Cells(rMaster.Row, ColUrsprung), .Cells(iRow + 1,  _
ColUrsprung))
If Not Left(rSlave.Value, Len(rMaster.Value)) = rMaster.Value Then
'gruppieren
.Range(.Cells(rMaster.Row, ColUrsprung), .Cells(rSlave.Row - 1, ColUrsprung)). _
Rows.Group
'Endzellen-Schleife verlassen
Exit For
End If
Next rSlave
Next rMaster
End With
End Sub
Dass nach 8 Gruppierungen innerhalb einer Ebene schluss ist weisst du aber, ja?
Grüße,
Klaus M.vdT.

Anzeige
etwas schöner
10.06.2013 15:16:29
Klaus
Hallo Jürgen,
diese Version ist noch etwas schöner:
Option Explicit
Sub GruppiereAutomatisch()
Const SpalteUrsprung As Long = 1 'die Hierachie-Ebene ensteht in Spalte A = 1
Const ErsteZeile As Long = 3  'Hierachie-Eintragungen ab Zeile 3
Dim LetzteZeile As Long
Dim rMaster As Range
Dim rSlave As Range
Dim i As Integer
With ActiveSheet
'alle Gruppen aufheben
On Error Resume Next
For i = 1 To 8
.Cells.Rows.Ungroup
Next i
On Error GoTo 0
LetzteZeile = .Cells(.Rows.Count, SpalteUrsprung).End(xlUp).Row
'jede Zelle als "Master" durchlaufen"
For Each rMaster In .Range(.Cells(ErsteZeile, SpalteUrsprung), .Cells(LetzteZeile,  _
SpalteUrsprung))
'für jede "Master" Zelle die Endzelle finden
For Each rSlave In .Range(.Cells(rMaster.Row, SpalteUrsprung), .Cells(LetzteZeile + 1,  _
SpalteUrsprung))
If Not Left(rSlave.Value, Len(rMaster.Value)) = rMaster.Value Then
'gruppieren
.Range(.Cells(rMaster.Row, SpalteUrsprung), .Cells(rSlave.Row - 1, SpalteUrsprung)). _
Rows.Group
'Endzellen-Schleife verlassen
Exit For
End If
Next rSlave
Next rMaster
End With
End Sub

Anzeige
AW: Bahnhof
10.06.2013 15:23:31
Jürgen
Hallo Klaus,
vielen Dank!
Das funktioniert ja schon ganz wunderbar.
Innerhalb einer Ebene gehen auch mehr als 8 Gruppierungen,
aber es gehen wohl nicht mehr als 8 Ebenen.
Hast du das mal eben so schnell geschrieben oder kannst du auf eine umfangreiche Makro-Sammlung zugreifen?
Nochmals vielen Dank für die Hilfe.
Jürgen

AW: Bahnhof
10.06.2013 15:26:32
Klaus
Hallo Jürgen,
Hast du das mal eben so schnell geschrieben
ja.
oder kannst du auf eine umfangreiche Makro-Sammlung zugreifen?
auch, aber da war nichts über "gruppieren" drinnen :-)
Grüße,
Klaus M.vdT.

Anzeige
nochmal optimiert
10.06.2013 15:42:26
Klaus
Hallo Jürgen,
ich hab nochmal optimiert, die "Schleife in der Schleife" sowie das unschöne "Exit For" konnte ich rauskürzen:
Option Explicit
Sub GruppiereAutomatisch()
Const SpalteUrsprung As Long = 1 'die Hierachie-Ebene ensteht in Spalte A = 1
Const ErsteZeile As Long = 3     'Hierachie-Eintragungen ab Zeile 3
Dim LetzteZeile As Long
Dim rMaster As Range
Dim AnzahlGruppe As Long
Dim i As Integer
With ActiveSheet
'alle Gruppen aufheben
On Error Resume Next
For i = 1 To 8
.Cells.Rows.Ungroup
Next i
On Error GoTo 0
LetzteZeile = .Cells(.Rows.Count, SpalteUrsprung).End(xlUp).Row
'jede Zelle als "Master" durchlaufen"
For Each rMaster In .Range(.Cells(ErsteZeile, SpalteUrsprung), .Cells(LetzteZeile,  _
SpalteUrsprung))
'für jede "Master" Zelle die Endzelle finden
AnzahlGruppe = Application.WorksheetFunction.CountIf(.Cells(1, SpalteUrsprung).EntireColumn, _
rMaster.Value & "*")
'gruppieren
If AnzahlGruppe > 1 Then rMaster.Resize(AnzahlGruppe, 1).Rows.Group
Next rMaster
End With
End Sub
Grüße,
Klaus M.vdT.

Anzeige
AW: nochmal optimiert
10.06.2013 15:52:17
Jürgen
Hallo Klaus,
nun ist es leider kaputt-optimiert :-(
Funktioniert nur noch bis zu 5. Ebene.
Gruß
Jürgen

AW: nochmal optimiert
10.06.2013 15:57:30
Klaus
nun ist es leider kaputt-optimiert :-(
Hi,
habe ich gerade auch bemerkt! Sorry, ich komme nicht dahinter warum es auf diesem Weg eine Ebene weniger hat ... Egal, nimm halt das vorherige :-)
An meiner zweiten Version (die du dir gerade anschaust) ist schöner, dass die Spalten und Zeilenindices beide in CONST an den Codeanfang ausgelagert sind. Das heisst, wenn du das Makro mal in Spalte F ab Zeile 17 einsetzen willst, musst du nur ganz oben zwei Werte ändern.
Die erste Version scheint zwar ähnlich variabel, ist es aber nicht: Sie funktioniert nur in Spalte A.
Übrigens schreibe ich Fliesstext mit knapp über 400 Anschlägen die Minute (circa 75 Worte) :-)
Grüße,
Klaus M.vdT.

Anzeige
AW: nochmal optimiert
10.06.2013 16:01:26
Jürgen
Hallo Klaus,
mit dieser kleinen Änderung geht es wieder: 
If AnzahlGruppe >= 1 Then ...
Danke
Jürgen

seltsam ...
10.06.2013 16:06:14
Klaus
Hallo Jürgen,
mit "AnzahlGruppe" wollte ich verhindern, dass eine einzelne Zelle gruppiert wird und so eine Ebene mehr reinschummeln. Seltsamerweise hat es das Gegenteil erzeugt und eine Ebene ausgesetzt ...
Da das von dir veränderte IF eh immer greift, kann man es auch ganz weglassen und sich in dem Zug die "AnzahlGruppe" variable sparen. Nochmal drei Zeilen weniger!
Option Explicit
Sub GruppiereAutomatisch()
Const SpalteUrsprung As Long = 1 'die Hierachie-Ebene ensteht in Spalte A = 1
Const ErsteZeile As Long = 3     'Hierachie-Eintragungen ab Zeile 3
Dim LetzteZeile As Long
Dim rMaster As Range
Dim i As Integer
With ActiveSheet
'alle Gruppen aufheben
On Error Resume Next
For i = 1 To 8
.Cells.Rows.Ungroup
Next i
On Error GoTo 0
LetzteZeile = .Cells(.Rows.Count, SpalteUrsprung).End(xlUp).Row
'jede Zelle als "Master" durchlaufen"
For Each rMaster In .Range(.Cells(ErsteZeile, SpalteUrsprung), .Cells(LetzteZeile, _
SpalteUrsprung))
'für jede "Master" Zelle die Endzelle finden und gruppieren
rMaster.Resize(Application.WorksheetFunction.CountIf(.Cells(1, SpalteUrsprung).EntireColumn, _
rMaster.Value & "*"), 1).Rows.Group
Next rMaster
End With
End Sub
Grüße,
Klaus M.vdT.

Anzeige
AW: seltsam ...
10.06.2013 16:15:15
Jürgen
Hallo Klaus,
'**********************
'alle Gruppen aufheben
On Error Resume Next
For i = 1 To 8
.Cells.Rows.Ungroup
Next i
On Error GoTo 0
'**********************
kann man wohl auch noch durch
'**********************
'alle Gruppen aufheben
Cells.ClearOutline
On Error GoTo 0
'**********************
ersetzen.
Wieder was gespart ;-)
Jürgen

AW: seltsam ...
10.06.2013 17:41:19
Klaus
Hallo Jürgen,
in meinem Test hat
.Cells.Rows.Ungroup
Nur eine Ebene der Gruppierung aufgehoben. Da es höchstens acht ebenen geben darf, hatte ich in meiner ersten Version noch stehen
.Cells.Rows.Ungroup
.Cells.Rows.Ungroup
.Cells.Rows.Ungroup
.Cells.Rows.Ungroup
.Cells.Rows.Ungroup
.Cells.Rows.Ungroup
.Cells.Rows.Ungroup
.Cells.Rows.Ungroup
und dass dann gegen die oben gezeigte Schleife ausgetauscht.
Es kann sein, dass der "ungroup" Block an sich gar nicht nötig ist. Probier doch mal aus was das Makro macht, wenn du ihn ganz weglässt (ich selbst hab grad kein Excel zur Verfügung).
Ich würd den Block aber drinnen lassen, der dauert nur eine 1/100 sek zum durchlaufen und du bist dir danach ganz sicher, das Excel die Gruppen sauber auf eine neue Vorlage setzt.
Man könnte noch die Variable "LetzteZeile" einsparen und stattdessen die letzte Zeile direkt in der For-Each Anweisung ermitteln, aber man soll auch nicht so viel optimieren dass es dann unübersichtlich wird ...
Grüße,
Klaus M.vdT.

Anzeige
AW: seltsam ...
10.06.2013 20:02:22
Jürgen
Hallo Klaus,
was häst du denn von Cells.ClearOutline?
Das funktioniert bei mir sehr gut. Ich weiß nur nicht wie schnell es ist.
Wie misst du die Ausführungsgeschwindigkeit?
Gruß
Jürgen

AW: seltsam ...
10.06.2013 20:10:52
Hajo_Zi
Hallo Jürgen,
Option Explicit
Private Declare Function timeGetTime Lib "winmm.dll" () As Long
' https://www.herber.de/forum/ _
archiv/936to940/t938376.htm
Function Dummy1() As Single
Dim lngStartTime As Single
lngStartTime = timeGetTime
Dim x As Long
For x = 1 To 200000
Next
Dummy1 = timeGetTime - lngStartTime
MsgBox Dummy1 & " millisekunden"
End Function
in dem Fall steht in einer Zelle =Dummy1

Anzeige
AW: seltsam ...
11.06.2013 08:19:51
Klaus
Hallo Jürgen,
wenn cells.clearoutline klappt, dann nimm das! Ich habe mir die nötigen Befehle aus dem Makrorekorder geholt, sehr oft gibt es da bessere alternativen.
Ich weiss ja nicht wie gross deine Datei ist, aber wenn ein Code funktioniert und in unter 0,5sec durchläuft gibt es eigentlich keinen Grund mehr zu optimieren. Aber einfach für den Spass an der Sache:
Sub ZeitMessung()
Dim t
t = Timer
Call MakroName
MsgBox "Das Makro brauchte " & Format(Timer - t, "0.00") & " Sekunden"
End Sub
Bei Call MakroName natürlich das Name deines Makros einfügen :-)
Grüße,
Klaus M.vdT.

Anzeige
AW: Bahnhof
10.06.2013 15:43:55
Jürgen
Hallo Klaus,
Respekt!
So schnell kann ich nicht mal normalen Fließtext schreiben.
Ich werde mir jetzt mal anschauen, was an der zweiten Version "schöner" ist.
Gruß
Jürgen

Beliebteste Forumthreads (12 Monate)

Anzeige
Jetzt das Excel-Portal bewerten: Deine Stimme zählt!

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige