Thema: Jahreskalender mit Monatsblättern anlegen

StandardModule: basMain

Sub Main()
   Dim wks As Worksheet
   Dim cmt As Comment
   Dim vYear As Variant
   Dim iRow As Integer
   Dim bln As Boolean
   Application.ScreenUpdating = False
   bln = Application.DisplayStatusBar
   Application.DisplayStatusBar = True
   Application.DisplayCommentIndicator = xlCommentIndicatorOnly
   Set wks = ActiveSheet
   vYear = InputBox( _
      prompt:="Gewünschtes Kalenderjahr angeben:", _
      Default:=Year(Date))
   Range("C1").Value = CInt(vYear)
   Workbooks.Add 1
   Call MonateAnlegen
   Call TageEintragen
   iRow = 1
   Do Until IsEmpty(wks.Cells(iRow, 1))
      With Worksheets(Month(wks.Cells(iRow, 2).Value))
         With .Cells(Day(wks.Cells(iRow, 2).Value), 1)
            .Interior.ColorIndex = 36
            Set cmt = .AddComment(wks.Cells(iRow, 1).Value)
            cmt.Shape.TextFrame.AutoSize = True
         End With
      End With
      iRow = iRow + 1
   Loop
   Application.DisplayStatusBar = bln
   Application.StatusBar = False
   Application.ScreenUpdating = True
End Sub

Private Sub MonateAnlegen()
   Dim iMonth As Integer
   For iMonth = 1 To 12
      If iMonth > 1 Then
         Worksheets.Add.Move after:=Worksheets(Worksheets.Count)
      End If
      ActiveSheet.Name = Format( _
         DateSerial(Range("C1").Value, iMonth, 1), "mmmm")
   Next iMonth
End Sub

Private Sub TageEintragen()
   Dim wks As Worksheet, wksMy As Worksheet
   Dim lDay As Long
   Dim iMonth As Integer, iDay As Integer
   Set wksMy = ThisWorkbook.Worksheets("Feiertage")
   For iMonth = 1 To 12
      Set wks = Worksheets(iMonth)
      Application.StatusBar = "Bearbeite Monat " & wks.Name
      wks.Columns(1).NumberFormat = "dd.mm.yy"
      wks.Columns(2).NumberFormat = "dddd"
      For lDay = DateSerial(wksMy.Range("C1").Value, iMonth, 1) To _
         DateSerial(wksMy.Range("C1").Value, iMonth + 1, 0)
         iDay = iDay + 1
         wks.Cells(iDay, 1) = lDay
         wks.Cells(iDay, 2) = lDay
         If WeekDay(lDay) = 7 Then
            wks.Cells(iDay, 1).Interior.ColorIndex = 34
            wks.Cells(iDay, 2).Interior.ColorIndex = 34
         ElseIf WeekDay(lDay) = 1 Then
            wks.Cells(iDay, 1).Interior.ColorIndex = 35
            wks.Cells(iDay, 2).Interior.ColorIndex = 35
         End If
      Next lDay
      iDay = 0
    Next iMonth
    Worksheets(1).Select
    ActiveWindow.Caption = "Jahreskalender " & wksMy.Range("C1").Value
End Sub

StandardModule: basFunction

Function Ostern(iYear As Integer)
   Dim iDay As Integer
   iDay = (((255 - 11 * (iYear Mod 19)) - 21) Mod 30) + 21
   Ostern = DateSerial(iYear, 3, 1) + iDay + (iDay > 48) + _
      6 - ((iYear + iYear \ 4 + iDay + (iDay > 48) + 1) Mod 7)
End Function

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