Thema: Jahreskalender mit Mitarbeiterliste und Feiertagen anlegen

StandardModule: Modul1

Sub MonateAnlegen()
   Dim wks As Worksheet
   Dim var As Variant
   Dim datDay As Date
   Dim iMonth As Integer, iCol As Integer, iCounter As Integer, iYear As Integer
   Dim sMonth As String
   Dim bln As Boolean
   With Application
      .ScreenUpdating = False
      bln = .DisplayStatusBar
      .DisplayStatusBar = True
   End With
   iYear = Cover.SpinButton1.Value
   Workbooks.Add
   Application.DisplayAlerts = False
   For iCounter = 1 To Worksheets.Count - 1
      Worksheets(2).Delete
   Next iCounter
   Application.DisplayAlerts = True
   Set wks = ThisWorkbook.Worksheets("Mitarbeiter")
   For iMonth = 1 To 12
      sMonth = Format(DateSerial(1, iMonth, 1), "mmmm")
      Application.StatusBar = "Lege Monat " & sMonth & " an..."
      Worksheets.Add after:=Worksheets(Worksheets.Count)
      ActiveSheet.Name = sMonth
      wks.Range(wks.Cells(3, 1), wks.Cells( _
         WorksheetFunction.CountA(wks.Columns(1)) + 1, 1)).Copy Range("A2")
      Range("A1").Value = "'" & ActiveSheet.Name & " " & iYear
      If Cover.OptionButton1.Value And Cover.OptionButton3.Value Then
         Call WithHW(iMonth)
      ElseIf Cover.OptionButton1.Value And Cover.OptionButton3.Value = False Then
         Call WithWsansH(iMonth)
      ElseIf Cover.OptionButton1.Value = False And Cover.OptionButton3.Value Then
         Call WithHsansW(iMonth)
      Else
         Call SansWH(iMonth)
      End If
      Rows(2).Value = Rows(1).Value
      Rows(2).NumberFormat = "ddd"
      Range("A2").Value = "Wochentage"
      Rows("1:2").Font.Bold = True
      Columns.AutoFit
   Next iMonth
   Application.DisplayAlerts = False
   Worksheets(1).Delete
   Application.DisplayAlerts = True
   Worksheets(1).Select
   ActiveWindow.Caption = "Jahreskalender " & iYear
   With Application
      .ScreenUpdating = True
      .DisplayStatusBar = bln
      .StatusBar = False
   End With
End Sub

Private Sub WithHW(ByVal iMonth As Integer)
   Dim cmt As Comment
   Dim rng As Range
   Dim var As Variant
   Dim datDay As Date
   Dim iYear As Integer, iCol As Integer
   iCol = 1
   iYear = Cover.SpinButton1.Value
   For datDay = DateSerial(iYear, iMonth, 1) To _
      DateSerial(iYear, iMonth + 1, 0)
      iCol = iCol + 1
      Set rng = Range(Cells(1, iCol), _
         Cells(WorksheetFunction.CountA(Columns(1)), iCol))
      var = Application.Match(CDbl(datDay), _
         ThisWorkbook.Worksheets("Feiertage").Columns(1), 0)
      Cells(1, iCol).Value = datDay
      With rng.Interior
         Select Case Weekday(datDay)
            Case 1
               .ColorIndex = 35
            Case 7
               .ColorIndex = 36
         End Select
         If Not IsError(var) Then
            .ColorIndex = 34
            Set cmt = Cells(1, iCol).AddComment( _
               ThisWorkbook.Worksheets("Feiertage").Cells(var, 2).Value)
            cmt.Shape.TextFrame.AutoSize = True
         End If
      End With
   Next datDay
End Sub

Private Sub WithHsansW(ByVal iMonth As Integer)
   Dim datDay As Date
   Dim iYear As Integer, iCol As Integer
   iCol = 1
   iYear = Cover.SpinButton1.Value
   For datDay = DateSerial(iYear, iMonth, 1) To _
      DateSerial(iYear, iMonth + 1, 0)
      If WorksheetFunction.Weekday(datDay, 2) < 6 Then
         iCol = iCol + 1
         Cells(1, iCol).Value = datDay
      End If
   Next datDay
End Sub

Private Sub WithWsansH(ByVal iMonth As Integer)
   Dim var As Variant
   Dim datDay As Date
   Dim iYear As Integer, iCol As Integer
   iCol = 1
   iYear = Cover.SpinButton1.Value
   For datDay = DateSerial(iYear, iMonth, 1) To _
      DateSerial(iYear, iMonth + 1, 0)
      var = Application.Match(CDbl(datDay), _
         ThisWorkbook.Worksheets("Feiertage").Columns(1), 0)
      If IsError(var) Then
         iCol = iCol + 1
         Cells(1, iCol).Value = datDay
      End If
   Next datDay
End Sub

Private Sub SansWH(ByVal iMonth As Integer)
   Dim var As Variant
   Dim datDay As Date
   Dim iYear As Integer, iCol As Integer
   iCol = 1
   iYear = Cover.SpinButton1.Value
   For datDay = DateSerial(iYear, iMonth, 1) To _
      DateSerial(iYear, iMonth + 1, 0)
      If WorksheetFunction.Weekday(datDay, 2) < 6 Then
         var = Application.Match(CDbl(datDay), _
            ThisWorkbook.Worksheets("Feiertage").Columns(1), 0)
         If IsError(var) Then
            iCol = iCol + 1
            Cells(1, iCol).Value = datDay
         End If
      End If
   Next datDay
End Sub

Sub FeiertageEinAus()
   With Worksheets("Feiertage")
      If .Visible = xlVeryHidden Then
         .Visible = True
         .Select
      Else
         .Visible = xlVeryHidden
         Worksheets(1).Select
      End If
   End With
End Sub

Sub MitarbeiterEinAus()
   With Worksheets("Mitarbeiter")
      If .Visible = xlVeryHidden Then
         .Visible = True
         .Select
      Else
         .Visible = xlVeryHidden
         Worksheets(1).Select
      End If
   End With
End Sub

Sub Zurueck()
   ActiveSheet.Visible = xlVeryHidden
   Worksheets(1).Select
End Sub

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