Grupperung aber heftig!

Bild

Betrifft: Grupperung aber heftig! von: Frank Sohn
Geschrieben am: 08.03.2005 17:09:32

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

Bild


Betrifft: AW: Grupperung aber heftig! von: Volker
Geschrieben am: 08.03.2005 17:18:47

Hallo Frank,

heftig ist, dass ich keine Ahnung hab, was rauskommen soll;-).
Laß doch mal ein Bsp. sehen.

Gruß
Volker


Bild


Betrifft: AW: Grupperung aber heftig! von: Björn B.
Geschrieben am: 09.03.2005 06:44:59

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


Bild


Betrifft: AW: Grupperung aber heftig! von: Frank Sohn
Geschrieben am: 09.03.2005 11:10:58

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


Bild


Betrifft: AW: Grupperung aber heftig! von: Björn B.
Geschrieben am: 09.03.2005 17:38:12

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


Bild


Betrifft: AW: Grupperung aber heftig! von: Frank Sohn
Geschrieben am: 09.03.2005 11:30:24

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


Bild


Betrifft: AW: Grupperung aber heftig! von: Volker
Geschrieben am: 09.03.2005 15:40:02

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


Bild


Betrifft: Puh, geschafft... von: Volker
Geschrieben am: 09.03.2005 17:34:31

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


Bild


Betrifft: AW: Puh, geschafft... von: Frank Sohn
Geschrieben am: 11.03.2005 12:46:46

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


Bild


Betrifft: AW: Puh, geschafft... von: volker
Geschrieben am: 14.03.2005 07:59:03

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


Bild


Betrifft: Letzter Versuch von: Björn B.
Geschrieben am: 11.03.2005 20:27:43

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 -


 Bild

Beiträge aus den Excel-Beispielen zum Thema "Makros deaktivieren bei Öffnen aus VBA"