AW: VBA - Gruppierung
12.10.2011 01:49:24
fcs
Hallo e-mo,
es gibt eine Grenze für die Anzahl Zeichen an Code pro Anweisung/Befehlszeile, die der Compiler verarbeiten kann. Ich kenne aber die genaue Zahl nicht.
Falls das der Fall sein sollte, dann die Tabellennamen auf mehrer Case-Zeilen verteilen
Auch die ausgeblendeten Tabellenblätter müssen berücksichtigt werden.
Diese kannst du jedoch auch mit einer Prüfung auf sichtbar erledigen.
Gruß
Franz
Sub GruppierenNeu()
Dim wks As Worksheet
Dim lngSpalte As Long
Dim Datum1 As Date, Datum2 As Date
'Datum des Vormonats
Datum2 = DateSerial(Year(Date), Month(Date), 1) - 1
Datum2 = DateSerial(Year(Datum2), Month(Datum2), 1)
'Datum des Vormonats im Vorjahr
Datum1 = DateSerial(Year(Datum2) - 1, Month(Datum2), 1)
Application.ScreenUpdating = False
For Each wks In ActiveWorkbook.Worksheets
If wks.Visible = xlSheetVisible Then
Select Case wks.Name
Case "Tabelle XYZ", "Tabelle ABC", "Tabelle XYZ1", "Tabelle ABC1", "Tabelle XYZ2", _
"Tabelle ABC2", "Tabelle XYZ3", "Tabelle ABC3"
Case "Tabelle XYZ4", "Tabelle ABC4", _
"Tabelle ABC5", "Tabelle XYZ5", "Tabelle ABC6", "Tabelle XYZ6"
'Diese Tabellen nicht Gruppieren
Case Else
With wks
.Columns.Ungroup
.Columns.Hidden = False
For lngSpalte = 1 To .Cells(2, .Columns.Count).End(xlToLeft).Column
Select Case lngSpalte
Case 1 To 6
'nicht gruppieren
Case 7 To 30 'G - AD
If .Cells(2, lngSpalte) Datum2 Then
.Columns(lngSpalte).Group
End If
Case 32 To 81 'AG - CC
If .Cells(2, lngSpalte) = Datum2 Then
.Columns(lngSpalte).ColumnWidth = 16
Else
.Columns(lngSpalte).ColumnWidth = 6.43
.Columns(lngSpalte).Group
End If
Case 84 To 95 'CF-CQ
If .Cells(2, lngSpalte) = Datum1 Then
.Columns(lngSpalte).ColumnWidth = 12
Else
.Columns(lngSpalte).ColumnWidth = 6.43
.Columns(lngSpalte).Group
End If
Case 96 To 107 'CR-DC
If .Cells(2, lngSpalte) = Datum2 Then
.Columns(lngSpalte).ColumnWidth = 12
Else
.Columns(lngSpalte).ColumnWidth = 6.43
.Columns(lngSpalte).Group
End If
Case 31, 57, 82, 83 'Spalten AE,BE,CD,CE
.Columns(lngSpalte).Group
Case Else
'do nothing
End Select
Next lngSpalte
End With
wks.Outline.ShowLevels RowLevels:=0, ColumnLevels:=1
End Select
End If
Next
Application.ScreenUpdating = True
End Sub