AW: Nummerierung erneuern und Zeilen gruppieren!
13.07.2009 22:38:09
Tino
Hallo,
versuche es mal.
kommt als Code in Modul1
Option Explicit
'Makro für die Nummer
Sub Nummern(ByVal Bereich As Range)
Dim iCount As Long, A As Long
Dim myAr
Dim LOffset As Long
LOffset = Bereich(1, 1).Row - 2
myAr = Range(Bereich, Bereich.Offset(0, 1))
For A = 1 To Ubound(myAr)
If myAr(A, 2) = 0 And Not IsDate(myAr(A, 2)) And myAr(A, 2) <> "" Then
iCount = iCount + 1
myAr(A, 2) = 0
Else
myAr(A, 2) = "=R" & A + LOffset & "C1 + 1"
End If
myAr(A, 1) = iCount
Next A
Range(Bereich, Bereich.Offset(0, 1)).FormulaR1C1 = myAr
End Sub
Sub Start_Gruppierung()
Dim Bereich As Range, rZeilen As Range
With Application
.ScreenUpdating = False
.EnableEvents = False
'hier die Tabelle anpassen ****************************************************
With Tabelle2
'hier eventuell den Bereich anpassen
Set Bereich = .Range("A6", .Cells(.Rows.Count, 2).End(xlUp).Offset(0, -1))
Call Nummern(Bereich) 'Nummerierung durchführen
.Columns(1).ClearOutline
.Outline.AutomaticStyles = False
.Outline.SummaryRow = xlAbove
.Outline.SummaryColumn = xlLeft
For Each Bereich In Bereich
If rZeilen Is Nothing Then
Set rZeilen = Bereich.Offset(1, 0)
End If
If Bereich.Offset(1, 0) <> Bereich Then
Set rZeilen = .Range(rZeilen, Bereich).EntireRow
rZeilen.Rows.Group
Set rZeilen = Nothing
End If
Next Bereich
End With
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Gruß Tino