Gliederung per VBA

Sub GruppierungErstellen() Dim s_Beginn As String Dim s_Ende As String Sheets("Tabelle11").Activate Range("A2").Select Do Until ActiveCell.Value = "" ActiveCell.Offset(1, 0).Select s_Beginn = ActiveCell.Address Do Until Len(ActiveCell.Value) = 4 Or ActiveCell.Value = "" ActiveCell.Offset(1, 0).Select Loop s_Ende = ActiveCell.Offset(-1, 0).Address Range(s_Beginn, s_Ende).Rows.Group Range(s_Ende).Offset(1, 0).Select Loop End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

' ********************************************************************** ' Modul: Modul1 Typ: Allgemeines Modul ' ********************************************************************** Option Explicit Sub gliederung() Dim lngStart As Long, lngRow As Long, lngEnd As Long, lngLast As Long lngLast = Cells(Rows.Count, 1).End(xlUp).Row For lngRow = 2 To lngLast If Cells(lngRow, 1).Font.Bold And Cells(lngRow, 1).Font.ColorIndex = 3 Then lngStart = lngRow + 1 For lngEnd = lngStart To lngLast + 1 If (Cells(lngEnd, 1).Font.Bold And Cells(lngEnd, 1).Font.ColorIndex = 3) Or lngEnd > lngLast Then Range(Cells(lngStart, 1), Cells(lngEnd - 1, 1)).EntireRow.Group Exit For End If Next End If Next End Sub

' ********************************************************************** ' Modul: Modul1 Typ: Allgemeines Modul ' ********************************************************************** Option Explicit Sub gliederung() Dim lngStart As Long, lngRow As Long, lngEnd As Long, lngLast As Long lngLast = Cells(Rows.Count, 1).End(xlUp).Row ActiveSheet.Rows.ClearOutline For lngRow = 2 To lngLast If Cells(lngRow, 1).Font.Bold And Cells(lngRow, 1).Font.ColorIndex = 3 Then lngStart = lngRow + 1 For lngEnd = lngStart To lngLast + 1 If (Cells(lngEnd, 1).Font.Bold And Cells(lngEnd, 1).Font.ColorIndex = 3) Or lngEnd > lngLast Then Range(Cells(lngStart, 1), Cells(lngEnd - 1, 1)).EntireRow.Group Exit For End If Next End If Next ActiveSheet.Outline.ShowLevels RowLevels:=1 '1 = Eingeklappt,, 2 = Ausgeklappt! End Sub

Hallo,
achso, ja dann:
Musste allerdings ein bisschen tricksen, den das Suchen nach Formaten per VBA läuft nur von der ersten Übereinstimmung bis zur letzten richtig. Danach findet die Methode alles Mögliche, nur nicht das richtige.

Public Sub GruppierungErstellen()

    Dim objStartCell As Range, objEndCell As Range
    Dim strStopAddress As String

    With Application.FindFormat.Font
        .FontStyle = "Fett"
        .ColorIndex = 3
    End With

    With Tabelle1

        Set objStartCell = .Cells.Find(What:="*", After:=.Cells(.Rows.Count, 1), _
            LookIn:=xlFormulas, LookAt:=xlPart, SearchDirection:=xlPrevious, _
            MatchCase:=False, SearchFormat:=True)

        If Not objStartCell Is Nothing Then

            Set objEndCell = .Cells(.Rows.Count, 1).End(xlUp)
            strStopAddress = objEndCell.Address

            Do

                .Range(objStartCell.Offset(1), objEndCell).EntireRow.Group
                Set objEndCell = objStartCell.Offset(-1)
                Set objStartCell = .Cells.FindPrevious(After:=objEndCell)

            Loop Until strStopAddress = objStartCell.Address
        End If
    End With

    Set objEndCell = Nothing
    Set objStartCell = Nothing

End Sub

Also Autor kann ich keinen speziell empfehlen, ich hab kein Buch über VBA. Aber ich würde mal sagen, alle anderen außer dem.
Gruß
Nepumuk

Beliebteste Forumthreads (12 Monate)

7 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread