VBA-Programmierung in Microsoft Excel

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

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