Gruppe
Format
Problem
Wie kann ich ein Jahreskalenderblatt anlegen und Wochenenden, den aktuellen Tag und Feiertage farblich markieren, ohne VBA einzusetzen? Bei Eingabe eines neuen Jahres soll eine Neuberechnung erfolgen.
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