Gruppe
DatumZeit
Bereich
Kalenderwoche
Thema
Tabellenblätter für Kalenderwochen anlegen und ein/ausblenden
Problem
Es sollen Tabellenblätter nach DIN 1355 angelegt, ausgeblendet, eingeblendet und gelöscht werden können.
Lösung
Geben Sie den nachfolgenden Code in ein Standardmodul ein und weisen Sie ihn einer Schaltfläche zu.
StandardModule: Modul1
Sub CreateWks()
Dim datStart As Date, datEnd As Date
Dim lKW As Long
Dim iKW As Integer
Dim sKW As String
Application.ScreenUpdating = False
datStart = DateSerial(Year(Date), 1, 1)
datEnd = DateSerial(Year(Date), 12, 31)
For lKW = datStart To datEnd Step 7
Worksheets.Add after:=Worksheets(Worksheets.Count)
iKW = ISOWeek(CDate(lKW))
If lKW = CLng(datStart) And iKW > 1 Then
sKW = "KW" & iKW & "S"
ElseIf lKW >= datEnd - 7 And iKW = 1 Then
sKW = "KW" & iKW & "E"
Else
sKW = "KW" & Format(iKW, "00")
End If
ActiveSheet.Name = sKW
Next lKW
Application.ScreenUpdating = True
Worksheets(1).Select
End Sub
Private Function ISOWeek(dat As Date) As Integer
With WorksheetFunction
ISOWeek = Fix((dat - .Weekday(dat, 2) - _
DateSerial(Year(dat + 4 - _
.Weekday(dat, 2)), 1, -10)) / 7)
End With
End Function
Sub WksHidden()
Dim iWks As Integer, iAct As Integer
Dim iKW As String, sKW As String
Application.ScreenUpdating = False
iKW = ISOWeek(Date)
If Month(Date) = 1 And iKW > 50 Then
sKW = "KW" & Format(iKW, "00") & "A"
ElseIf Month(Date) = 12 And iKW = 1 Then
sKW = "KW01" & "E"
Else
sKW = "KW" & Format(iKW, "00")
End If
For iWks = 2 To Worksheets.Count
If Worksheets(iWks).Name = sKW Then
iAct = iWks
Exit For
End If
Next iWks
For iWks = 2 To Worksheets.Count
If iWks < iAct - 4 Or iWks > iAct + 4 Then
Worksheets(iWks).Visible = False
Else
Worksheets(iWks).Visible = True
End If
Next iWks
Application.ScreenUpdating = True
End Sub
Sub WksNoHidden()
Dim wks As Worksheet
Application.ScreenUpdating = False
For Each wks In Worksheets
wks.Visible = True
Next wks
Application.ScreenUpdating = True
End Sub
Sub WksDelete()
Dim wks As Worksheet
With Application
.ScreenUpdating = False
.DisplayAlerts = False
For Each wks In Worksheets
If wks.Index > 1 Then wks.Delete
Next wks
.DisplayAlerts = True
.ScreenUpdating = True
End With
End Sub