ich möchte gerne eine Tabelle automatisch gruppieren lassn.
Gruppiert werden soll wenn der Wert in Saplte "A" und "G" gleich ist.
Anbei ein Muster.
Danke!
Gruß
Ludmila
https://www.herber.de/bbs/user/95343.xlsm
Sub Gruppieren()
Dim rng As Range, ArData1, ArData2
Dim n&, nn&
Dim varSuche
On Error GoTo ErrorHandler:
Evenst_ False
With Tabelle3 'evtl. Tabelle anpassen
.UsedRange.ClearOutline
.Outline.AutomaticStyles = False
'Bereich ab A8
Set rng = Intersect(.Range("A8", .Cells(.Rows.Count, 1)), .UsedRange)
If rng Is Nothing Then GoTo ErrorHandler:
'Daten Spalte A
ArData1 = rng.Value
'Daten Spalte G
ArData2 = rng.Offset(, 6).Value
With rng
For n = 1 To UBound(ArData1)
If ArData1(n, 1) "" Then
varSuche = ArData1(n, 1)
nn = n + 1
End If
If varSuche "" Then
If nn > 0 Then
If ArData2(n, 1) = varSuche Then
.Rows(nn).Resize(n - nn + 1).Rows.Group
varSuche = Empty
nn = 0
End If
End If
End If
Next n
End With
.Outline.ShowLevels RowLevels:=1
End With
ErrorHandler:
Evenst_ True
End Sub
Sub Evenst_(booSchalter As Boolean)
With Application
.ScreenUpdating = booSchalter
.EnableEvents = booSchalter
End With
End Sub
Gruß Tino
Sub gruppieren()
Dim i As Integer
Dim n As Integer
Dim varWert As Variant, Zeile_L1 As Long, Zeile_L7 As Long
Dim wks As Worksheet
Set wks = ActiveSheet
'Makrobremsen lösen
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
.EnableEvents = False
End With
With wks
'vorhandene Gliederung ggf. entfernen
.Cells.ClearOutline
'Optionen für Gliederung setzen
With .Outline
.AutomaticStyles = False
.SummaryRow = xlAbove
.SummaryColumn = xlLeft
End With
'letzte Zeilen in Spalten A und G ermiitteln
Zeile_L1 = .Cells(.Rows.Count, 1).End(xlUp).Row
Zeile_L7 = .Cells(.Rows.Count, 7).End(xlUp).Row
'Zellen in Spalte A abarbeiten
For n = 13 To Zeile_L1
If .Cells(n, 1).Value "" Then
varWert = .Cells(n, 1).Value
'Zeilen in Spalte G bis zum Ende der Liste abarbeiten
For i = n To Zeile_L7
If .Cells(i, 7).Value = varWert Then
If i > n Then
.Range(.Rows(n + 1), .Rows(i)).Rows.Group
End If
End If
Next i
End If
Next n
End With
'Makrobremsen zurücksetzen
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
.EnableEvents = True
End With
End Sub
'Als kleines Extra
Sub Gruppierung_entfernen()
'vorhandene Gliederung im aktiven Blatt entfernen
ActiveSheet.Cells.ClearOutline
End Sub