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
580to584
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
580to584
580to584
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Nächster Thread
Nächster Thread
Vorwärts blättern
Inhaltsverzeichnis

Grupperung aber heftig!

Grupperung aber heftig!
08.03.2005 17:09:32
Frank
Hallo
ich habe ein Workbook angehängt.
Meim Problem ist das ich im enthaltenen Worksheet folgende Einträge habe
A2 .
A3 1
A4 1.1
A5 1.2
A6 1.3
A7 1.4
A8 1.4.1
A9 1.4.3
A10 2
A11 2.1
A12 3
A13 3.1
Mann erkennt es handelt sich um eine Baumstruktur als Liste!
Diese möchte ich nun Gruppieren also z.B: mus als erstes 1.4.1 und 1.4.3
zu 1.4 dann das mit 1.1 und 1.2 ... zu 1
Ich kriegs nicht hin vielleicht hat von euch jemand eine Idee
(Habs rekursiv versucht)
mfg
Frank

10
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Grupperung aber heftig!
08.03.2005 17:18:47
Volker
Hallo Frank,
heftig ist, dass ich keine Ahnung hab, was rauskommen soll;-).
Laß doch mal ein Bsp. sehen.
Gruß
Volker
AW: Grupperung aber heftig!
09.03.2005 06:44:59
Björn
Hallo Frank,
meinst du so?

Sub Gruppieren()
Const Erste_Zeile = 3
Const Letzte_Zeile = 13
Dim Ebene(Letzte_Zeile - Erste_Zeile) As Integer
Dim Maximum As Integer
For reihe = Erste_Zeile To Letzte_Zeile
Ebene(reihe - Erste_Zeile) = 1
For Zeichen = 1 To Len(Cells(reihe, 1))
If Mid(Cells(reihe, 1), Zeichen, 1) = "." Then Ebene(reihe - Erste_Zeile) = Ebene(reihe - Erste_Zeile) + 1
Next
If Ebene(reihe - Erste_Zeile) > Maximum Then Maximum = Ebene(reihe - Erste_Zeile)
Next
With ActiveSheet.Outline
.AutomaticStyles = False
.SummaryRow = xlAbove
.SummaryColumn = xlRight
End With
For aktuelle_Ebene = 2 To Maximum Step 1
For reihe = Erste_Zeile To Letzte_Zeile
If Ebene(reihe - Erste_Zeile) >= aktuelle_Ebene Then
Folgezeilen = 0
Do While reihe + 1 + Folgezeilen < Letzte_Zeile
If Ebene(reihe - Erste_Zeile + 1 + Folgezeilen) = aktuelle_Ebene Then
Folgezeilen = Folgezeilen + 1
Else
Exit Do
End If
Loop
For Feld = reihe - Erste_Zeile To reihe - Erste_Zeile + Folgezeilen
If Ebene(Feld) = aktuelle_Ebene Then Ebene(Feld) = 0
Next
Rows("" & reihe & ":" & reihe + Folgezeilen & "").Rows.Group
End If
Next
Next
End Sub

Gruß
Björn
Anzeige
AW: Grupperung aber heftig!
09.03.2005 11:10:58
Frank
Hallo,
Ja ich habe mich etwas komisch ausgedrückt.
Raus kommen soll ein Gruppierung.
. in A2 ist root!
jeweils (wie auch im Worksheet ist alles fett also A2,A3, A7, ...)
sind die Überschriften oder Verzeichnisse oder ....
der Algorithmus sollte (meiner Meinung depth-first) also in dem Beispiel mit dem
tiefsten Level beginnen.
Das wird dann gruppiert (also row 8 und row 9,..)!
Habe ein per Hand gruppiertes Worksheet nachgelegt.
Neues Worksheet liegt unter : https://www.herber.de/bbs/user/19390.xls
mfg
Frank
Anzeige
AW: Grupperung aber heftig!
09.03.2005 17:38:12
Björn
Hallo Frank,
wieso habe ich eigentlich das Gefühl, dass du meinen Beitrag gar nicht gelesen hast?
Nun gut, auch deine präzisierten Anforderungen lassen sich lösen:

Sub Gruppieren()
Const Erste_Zeile = 3 'erste Zeile nach Root!
Const Letzte_Zeile = 17
Dim Ebene(Letzte_Zeile - Erste_Zeile) As Integer
Dim Maximum As Integer
For reihe = Erste_Zeile To Letzte_Zeile
Ebene(reihe - Erste_Zeile) = 1
For Zeichen = 1 To Len(Cells(reihe, 1))
If Mid(Cells(reihe, 1), Zeichen, 1) = "." Then Ebene(reihe - Erste_Zeile) = Ebene(reihe - Erste_Zeile) + 1
Next
If Ebene(reihe - Erste_Zeile) > Maximum Then Maximum = Ebene(reihe - Erste_Zeile)
Next
With ActiveSheet.Outline
.AutomaticStyles = False
.SummaryRow = xlAbove
.SummaryColumn = xlRight
End With
For aktuelle_Ebene = 2 To Maximum Step 1
For reihe = Erste_Zeile To Letzte_Zeile
If Ebene(reihe - Erste_Zeile) >= aktuelle_Ebene Then
Folgezeilen = 0
Do While reihe + 1 + Folgezeilen < Letzte_Zeile
If Ebene(reihe - Erste_Zeile + 1 + Folgezeilen) = aktuelle_Ebene Then
Folgezeilen = Folgezeilen + 1
Else
Exit Do
End If
Loop
For Feld = reihe - Erste_Zeile To reihe - Erste_Zeile + Folgezeilen
If Ebene(Feld) = aktuelle_Ebene Then Ebene(Feld) = 0
Next
Rows("" & reihe & ":" & reihe + Folgezeilen & "").Rows.Group
End If
Next
Next
Rows("" & Erste_Zeile & ":" & Letzte_Zeile & "").Rows.Group
End Sub

Gruß
Björn
Anzeige
AW: Grupperung aber heftig!
09.03.2005 11:30:24
Frank
Hi,
im Modul Resultat steht das per Hand eingefügte Gruppierungsbeispiel!
Link zum Worksheet ist : https://www.herber.de/bbs/user/19390.xls
Gruss Frank
AW: Grupperung aber heftig!
09.03.2005 15:40:02
Volker
Hallo Frank,
hier mal ein 1. Entwurf

Private Sub GrpResult()
Dim i, j, k, zeile As Integer
With ActiveSheet.Outline
.AutomaticStyles = False
.SummaryRow = xlAbove
.SummaryColumn = xlRight
End With
zeile = Cells(2, 1).End(xlDown).Row 'letzte Zeile
i = 3
ActiveSheet.Rows(i & ":" & zeile).Group
j = i + 1
While i < zeile
k = j
While Left(Cells(i, 1), 1) = Left(Cells(k, 1), 1)
k = k + 1
Wend
If k > j Then
'ActiveSheet.Range(Rows(j), Rows(k - 1)).Group
ActiveSheet.Rows(j & ":" & k - 1).Group
End If
i = k
j = k + 1
Wend
End Sub

Bisher wird nur bis zur 1. Ebene gruppiert und würde z.B. 66.x und 67.x gruppieren.
Werde noch versuchen, die 2. Ebene zu gruppieren und 2-stellige "Hauptgruppen" zu berücksichtigen.
Dazu braucht es irgendwas mit
While Left(Cells(i, 1), instr(Cells(i, 1),".")-1) = Left(Cells(k, 1)......
also den Punkt suchen
Ev. macht man für die 2. Ebene eine 2. while-wend Schleife.
Kannst ja parallel selber weiter probieren.
Gruß
Volker
Anzeige
Puh, geschafft...
09.03.2005 17:34:31
Volker
Hallo Frank,
ich glaub, ich habs:

Private Sub GrpResult()
Dim i, j, k, l, m, n, zeile As Integer
Dim test As String
With ActiveSheet.Outline
.AutomaticStyles = False
.SummaryRow = xlAbove
.SummaryColumn = xlRight
End With
zeile = Cells(2, 1).End(xlDown).Row 'letzte Zeile
i = 3 'steht die 1 immer in Zeile3 ?
ActiveSheet.Rows(i & ":" & zeile).Group
j = i + 1
While i < zeile
k = j
While Left(Cells(i, 1), Len(Cells(i, 1))) = Left(Cells(k, 1), Len(Cells(i, 1)))
k = k + 1
Wend
If k > j Then
ActiveSheet.Rows(j & ":" & k - 1).Group 'Ebene1
End If
l = i + 1
While l < k
m = l + 1
n = m
While Mid(Cells(l, 1), InStr(Cells(l, 1), "."), 2) = Mid(Cells(n, 1), InStr(Cells(l, 1), "."), 2)
n = n + 1
Wend
If n > m Then
ActiveSheet.Rows(m & ":" & n - 1).Group 'Ebene2
End If
l = n
'm = l + 1
Wend
i = k
j = k + 1
Wend
End Sub

Einzige Einschränkung: 2.Ebene nur einstellig
Gruß
Volker
Hiermit kannst Du alle Gruppierungen auf einmal löschen:
Sub ungroup()
zeile = Cells(2, 1).End(xlDown).Row 'letzte Zeile
While 1
On Error GoTo ende
ActiveSheet.Rows("2:" & zeile).ungroup
Wend
ende:
Hab's zwar getestet
Anzeige
AW: Puh, geschafft...
11.03.2005 12:46:46
Frank
Hallo,
DANKE für die Antwort, ich werde es sofort testen. Hatte mächtig zu tun deshalb habe ich
nicht sofort geantwortet.
Allerdings sollte die Struktur nicht auf Ebene 3 limitiert sein z.B: tiefstes Element
kann auch 1.4.3.2.5.1 sein!
Gruss
Franky
AW: Puh, geschafft...
14.03.2005 07:59:03
volker
Moin Franky,
wie gesagt, ist ja auch erstmal ein nur ein Ansatz.
Wenn die Tiefe nicht limitiert ist, hast Du mit den verschachtelten Schleifen wahrscheinlich schlechte Karten. Ist bei 2 Ebenen schon nicht ganz einfach, bei den Zählervariablen den Überblick zu behalten. Da kann man besser die Schleifen jeder Vertiefungsebene hintereinander setzten.
Gruß
Volker
Anzeige
Letzter Versuch
11.03.2005 20:27:43
Björn
Hallo Frank,
dies ist mein letzter Versuch mit dir Kontakt aufzunehmen, nachdem ich bereits zwei Beiträge platziert habe, von denen du scheinbar keinen wirklich gelesen hast.
Schau hier rein
https://www.herber.de/forum/messages/582797.html
oder vergiß es.
Gruß
Björn
- Ohne Rückmeldungen, vergeht die Lust am Antworten -

Beliebteste Forumthreads (12 Monate)

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

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige