Gruppe
DatumZeit
Problem
Es sollen Tabellenblätter nach DIN 1355 angelegt, ausgeblendet, eingeblendet und gelöscht werden können.
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