AW: Kalender mit besonderer Funktion
25.01.2015 09:37:56
Ralf P.
Den hatte ich mir 2004 mal erstellt. Den kannst du deinen Bedürfnissen anpassen.
Die Feiertags function ist aus dem Internet.
Gruß
Ralf
Dim Datum As Date
Dim FT
Dim Y, X, Monat1, Monat2, A, Jahr
Dim Objekt1 As Variant
Sub Kalender_erstellen()
Jahr = InputBox("Welches Jahr?", , "2006")
On Error Resume Next
Worksheets(Jahr).Select
If Not ActiveSheet.Name = Jahr Then Worksheets.Add.Name = Jahr
ActiveWindow.DisplayGridlines = False
Application.ScreenUpdating = False
Cells.Delete
With Cells
.Select
.MergeCells = False
.ClearContents
.ColumnWidth = 3
.Borders.LineStyle = xlLineStyleNone
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
With .Font
.Name = "Tahoma"
.FontStyle = "Standard"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = 0
End With
End With
Datum = "01.01." & Jahr
X = 2
For Y = 2 To 57 Step 5
Cells(X, Y).ColumnWidth = 3
Cells(X, Y + 1).ColumnWidth = 3
Cells(X, Y + 2).ColumnWidth = 3
Cells(X, Y + 3).ColumnWidth = 0.2
Cells(X, Y + 4).ColumnWidth = 0.2
Next Y
A = 1
For Y = 2 To 57 Step 5
For X = 3 To 34
With Cells(X, Y)
.Value = Datum
.NumberFormat = "ddd"
.Offset(0, 1).Value = Datum
.Offset(0, 1).NumberFormat = "dd"
.Offset(0, 2).Value = Format(Datum, "ww", vbMonday, vbFirstFourDays)
Select Case Cells(X, Y).Text
Case "Sa", "So"
.Font.ColorIndex = 3
Case Else
.Font.ColorIndex = 0
End Select
FT = Feiertag(Datum)
If Not FT = "" Then
If Not Right(FT, 1) = "*" Then 'wenn der feiertag am ende _
keinen stern hat (nicht bundeseinheitliche feiertage, eventl. in der function anpassen)
.Offset(0, 1).Font.Bold = True
.Offset(0, 1).Font.ColorIndex = 3
End If
.Offset(0, 1).AddComment
.Offset(0, 1).Comment.Text Text:=FT 'und der name als kommentar in _
die datumzelle eingetragen
End If
End With
Monat1 = Month(Datum)
With Range(Cells(X, Y), Cells(X, Y + 2))
.Borders.LineStyle = xlContinuous
.Borders.Weight = xlThin
End With
Datum = Datum + 1
Monat2 = Month(Datum)
If Monat1 <> Monat2 Then Exit For
Next X
With Range(Cells(2, Y), Cells(X, Y + 2))
.Interior.ColorIndex = 15
.Interior.Pattern = xlSolid
With .Borders
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = 5
End With
With .Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
End With
With Range(Cells(2, Y), Cells(2, Y + 2))
.MergeCells = True
.Value = Datum - 1
.NumberFormat = "mmm/yy"
.Font.Bold = True
.Interior.ColorIndex = 33
.Interior.Pattern = xlSolid
End With
Next Y
With Range("AA1:AH1")
.Merge
.FormulaR1C1 = Jahr
.Font.Bold = True
.Font.ColorIndex = 3
With .Font
.Name = "Tahoma"
.Size = 16
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleSingle
End With
End With
Rows("3:60").RowHeight = 12
Rows("2").RowHeight = 13
Rows("1").RowHeight = 20
Cells(1, 1).Select
End Sub
Sub Feiertagsliste()
Dim FTL As Worksheet
Dim StartDatum As Date
Dim EndDatum As Date
Dim i As Date
Dim StartJahr As Integer
Dim EndJahr As Integer
Dim Zeile As Long
Dim Spalte As Long
Dim FT As String
Set FTL = Worksheets("Feiertage")
StartJahr = InputBox("Welches StartJahr?", , "2011")
EndJahr = InputBox("Welches endJahr?", , "2020")
StartDatum = DateSerial(StartJahr, 1, 1)
EndDatum = DateSerial(EndJahr + 1, 1, 1) - 1
With FTL
.Cells.ClearContents
.Select
.Cells(1, 1) = "Feiertage / Jahre"
Zeile = 2
Spalte = 1
For i = StartDatum To DateSerial(StartJahr + 1, 1, 1) - 1
FT = Feiertag(i)
If FT <> "" Then
.Cells(Zeile, Spalte) = FT
Zeile = Zeile + 1
End If
Next i
Zeile = 1
Spalte = 1
For i = StartDatum To EndDatum
If Day(i) = 1 And Month(i) = 1 Then
Spalte = Spalte + 1
Zeile = 1
.Cells(Zeile, Spalte) = i
Zeile = Zeile + 1
End If
FT = Feiertag(i)
If FT <> "" Then
.Cells(Zeile, Spalte) = i
Zeile = Zeile + 1
End If
Next i
.Rows(1).NumberFormat = "yyyy"
.Range(.Cells(2, 2), .Cells(.UsedRange.Rows.Count, .UsedRange.Columns.Count)).NumberFormat = _
"ddd, dd/mm"
.Range(.Cells(1, 1), .Cells(.UsedRange.Rows.Count, .UsedRange.Columns.Count)).Borders. _
LineStyle = xlContinuous
.Cells.HorizontalAlignment = xlCenter
.Columns(1).HorizontalAlignment = xlLeft
End With
End Sub
Function Feiertag(Datum As Date) As String
Dim J%, D%
Dim O As Date
J = Year(Datum)
D = (((255 - 11 * (J Mod 19)) - 21) Mod 30) + 21
O = DateSerial(J, 3, 1) + D + (D > 48) + 6 - ((J + J \ 4 + D + (D > 48) + 1) Mod 7)
Select Case Datum
Case Is = DateSerial(J, 1, 1)
Feiertag = "Neujahr"
Case Is = DateSerial(J, 1, 6)
Feiertag = "Heilige Dreikönige*"
Case Is = DateAdd("D", -2, O)
Feiertag = "Karfreitag"
Case Is = O
Feiertag = "Ostersonntag"
Case Is = DateAdd("D", 1, O)
Feiertag = "Ostermontag"
Case Is = DateSerial(J, 5, 1)
Feiertag = "1. Mai"
Case Is = DateAdd("D", 39, O)
Feiertag = "Christi Himmelfahrt"
Case Is = DateAdd("D", 49, O)
Feiertag = "Pfingstsonntag"
Case Is = DateAdd("D", 50, O)
Feiertag = "Pfingstmontag"
Case Is = DateAdd("D", 60, O)
Feiertag = "Fronleichnam*"
Case Is = DateSerial(J, 8, 15)
Feiertag = "Maria Himmelfahrt*"
Case Is = DateSerial(J, 10, 3)
Feiertag = "Deutsche Einheit"
Case Is = DateSerial(J, 11, 22) - (DateSerial(J, 11, 18) Mod 7)
Feiertag = "Buß- und Bettag*"
Case Is = DateSerial(J, 10, 31)
Feiertag = "Reformationstag*"
Case Is = DateSerial(J, 11, 1)
Feiertag = "Allerheiligen*"
Case Is = DateSerial(J, 12, 24)
Feiertag = "Heilig Abend*"
Case Is = DateSerial(J, 12, 25)
Feiertag = "1. Weihnachtsfeiertag"
Case Is = DateSerial(J, 12, 26)
Feiertag = "2. Weihnachtsfeiertag"
Case Is = DateSerial(J, 12, 31)
Feiertag = "Silvester*"
Case Else
Feiertag = ""
End Select
End Function