Microsoft Excel

Excel und VBA: Formeln, Programmierung, Lösungen

Die Excel/VBA-Beispiele

Thema

Tabellenblätter für Kalenderwochen anlegen und ein/ausblenden

Gruppe

Kalenderwoche

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

    

Beiträge aus dem Excel-Forum zu den Themen DatumZeit und Kalenderwoche