AW: Jahreskalender
18.01.2013 11:24:11
Hajo_Zi
Option Explicit
Dim Jahr
Public Function Ostern(Yr As Integer)
Dim d As Integer
d = (((255 - 11 * (Yr Mod 19)) - 21) Mod 30) + 21
Ostern = DateSerial(Yr, 3, 1) + d + (d > 48) + _
6 - ((Yr + Yr \ 4 + d + (d > 48) + 1) Mod 7)
End Function
Sub Main()
Application.ScreenUpdating = False
Jahr = InputBox("Gewünschtes Kalenderjahr angeben (Format: 1999):")
Worksheets("Feiertage").Range("C1").Value = CInt(Jahr)
Workbooks.Add
Call MonateAnlegen
Call TageEintragen(Jahr)
End Sub
Private Sub MonateAnlegen()
Dim i%
For i = 1 To Worksheets.Count - 1
Application.DisplayAlerts = False
Worksheets(1).Delete
Application.DisplayAlerts = True
Next i
ActiveSheet.Name = Jahr
End Sub
Private Sub TageEintragen(Jahr)
Dim m%, d%
Dim Loi As Variant
Cells(1, 1) = CDate("01.01." & Jahr)
Cells(1, 2).Formula = "=" & Cells(1, 1).Address
Range(Cells(2, 2), Cells(CDate("31.12." & Jahr) - CDate("01.01." & Jahr), 1)).Formula = _
"=" & Cells(1, 1).Address(False, False) & "+1"
For d = 1 To CDate("31.12." & Jahr) - CDate("01.01." & Jahr)
If WeekDay(Cells(d, 1)) = 7 Then
Range(Cells(d, 1), Cells(d, 2)).Interior.ColorIndex = 34
ElseIf WeekDay(Cells(d, 1)) = 1 Then
Range(Cells(d, 1), Cells(d, 2)).Interior.ColorIndex = 35
End If
If Not IsError(Application.Match(CLng(Cells(d, 1)), ThisWorkbook.Worksheets(1).Columns( _
2), 0)) Then
Cells(d, 1).Interior.ColorIndex = 36
Cells(d, 1).Offset(0, 1).Interior.ColorIndex = 36
Cells(d, 1).NoteText Cells(d, 1)
End If
Next d
End Sub
Private Sub FeiertageEintragen()
Dim TB As Worksheet
Dim C As Range
Dim i%
Set TB = ThisWorkbook.Worksheets("Feiertage")
i = 1
Do Until IsEmpty(TB.Cells(i, 1))
Set C = Worksheets(Month(TB.Cells(i, 2))).Cells(Day(TB.Cells(i, 2)), 1)
C.Interior.ColorIndex = 36
C.Offset(0, 1).Interior.ColorIndex = 36
C.NoteText TB.Cells(i, 1)
i = i + 1
Loop
End Sub
Private Sub BlaetterLoeschen()
Dim i%
For i = 13 To Worksheets.Count
Application.DisplayAlerts = False
Worksheets(13).Delete
Next i
End Sub