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"