Kode til gruppér

Jo det skulle nok kunne lade sig gøre.
Har du prøvet funktionen "Outline"?

Den ligger i "Data"-menuen.
på dansk hedder det vist noget med grupper og disposition.

For at det skal fungere med en gruppering forudsætter det at du indsætter en ny række under hvert dyr, og her udfylder kolonne A og B (1 og abe f.eks.)

Marker herefter alle rækker med aber undtagen den nye række, du har indsat
Vælg Data->Grupper og disposition->Grupper...
Du vil nu se nogle dispositoponsknapper tilføjet ude til venstre. Brug dem til at folde grupperne sammen/ud igen.

Der kan godt indsættes nye rækker uden ar ødelægge grupperingen.

Der er tale om rigtigt mange data her. Jeg forestiller mig egentligt noget med en for next løkke der grupperer indtil næste udfyldte celle i kolonne A.

her er et udgangspumkt for noget kode, hvis du har afbilledet dine data rigtigt.
test det. det kan laves med automatisk selection.

Start med at markere alle data i kolonne A og kør så makroen.

Sub GroupThem()
Dim RangeToUse As Range
Dim SingleArea As Range
Selection.SpecialCells(xlCellTypeBlanks).Select
Set RangeToUse = Selection
If RangeToUse.Areas.Count = 1 Then
    RangeToUse.Rows.Group
Else
    For Each SingleArea In RangeToUse.Areas
        SingleArea.Rows.Group
    Next
End If
End Sub

Tommy du er en skat - lægger du lige et svar ? Den ser ud til at være perfekt.

ok :-)

vær lige opmærksom på at hele ideen baserer sig på at der er tomme celler, der hvor der skal grupperes

Med denne behøver du ikke først markere noget.
den sætter også +'erne foroven.

Sub GroupThem()
Dim RangeToUse As Range
Dim SingleArea As Range
    ActiveSheet.Outline.SummaryRow = xlAbove
    Set RangeToUse = Range(Cells(1, 2), Cells(65536, 2).End(xlUp)). _
            Offset(0, -1).SpecialCells(xlCellTypeBlanks)
    If RangeToUse.Areas.Count = 1 Then
        RangeToUse.Rows.Group
    Else
        For Each SingleArea In RangeToUse.Areas
            SingleArea.Rows.Group
        Next
    End If
End Sub

Fedest - Tusind tak for hjælpen...