Excel 97/2000/XP Kalender mit VBA
'© Marcus Börger 1999-2002
'
' http://www.marcus-boerger.de/?tools/zeit/
'
'Alle hier vorgestellten VisualBasic for Applications ((tm) Microsoft)
'dürfen privat und komerziell benutzt werden, wenn die Verweise und
'Kommentare auf mich unverändert bleiben!
'Dies gilt insbesondere auch dann, wenn der Sourcecode verändert wird.
'Hierzu bitte im Einzelfall nachfragen.
'
Private Sub Workbook_Open()
'Beim öffnen der Datei dem Modul "Kalender" den aktuellen Wert für die Zelle Jahr übergeben.
Call SetzeJahr(Names.Item("Jahr").RefersToRange.Value)
BlattschutzAlle_Setzen
End Sub
Private Sub Workbook_Activate()
'Kontextmenue Anpassen
Kontextmenue_Add
End Sub
Private Sub Workbook_Deactivate()
Kontextmenue_Delete
End Sub
Private Sub Workbook_SheetActivate(ByVal Sheet As Object)
Application.CommandBars("Cell").Controls("Kalender neu erstellen").Enabled = (InStr(Sheet.CodeName, "Kalender") > 0)
End Sub
Private Sub Kontextmenue_Add()
Dim MenueEintrag As Object
Set MenueEintrag = Application.CommandBars("Cell").Controls.Add(Temporary:=True)
With MenueEintrag
.BeginGroup = True
.Caption = "Alle Blätter entsperren"
.OnAction = "BlattschutzAlle_Aufheben"
.DescriptionText = "Hebt den Blattschutz für alle Blätter auf."
.Enabled = BlaetterGesperrt
End With
Set MenueEintrag = Application.CommandBars("Cell").Controls.Add(Temporary:=True)
With MenueEintrag
.BeginGroup = False
.Caption = "Alle Blätter sperren"
.OnAction = "BlattschutzAlle_Setzen"
.DescriptionText = "Setzt den Blattschutz für alle Blätter."
.Enabled = Not BlaetterGesperrt
End With
Set MenueEintrag = Application.CommandBars("Cell").Controls.Add(Temporary:=True)
With MenueEintrag
.BeginGroup = True
.Caption = "Kalender neu erstellen"
.OnAction = "Kontext_Erstelle_Kalender"
.DescriptionText = "Erstellt alle Kalender neu, bhält aber deren Eintragungen unverändert."
.Enabled = (InStr(ActiveSheet.CodeName, "Kalender") > 0)
End With
End Sub
Private Sub Kontextmenue_Delete()
Application.CommandBars("Cell").Controls("Kalender neu erstellen").Delete
Application.CommandBars("Cell").Controls("Alle Blätter entsperren").Delete
Application.CommandBars("Cell").Controls("Alle Blätter sperren").Delete
End Sub
'© Marcus Börger 1999-2002
'
' http://www.marcus-boerger.de/?tools/zeit/
'
'Alle hier vorgestellten VisualBasic for Applications ((tm) Microsoft)
'dürfen privat und komerziell benutzt werden, wenn die Verweise und
'Kommentare auf mich unverändert bleiben!
'Dies gilt insbesondere auch dann, wenn der Sourcecode verändert wird.
'Hierzu bitte im Einzelfall nachfragen.
'
Option Explicit
Dim OJahr As Integer
Public Function Ostern(Jahr As Integer) As Date
'Ostern nach Physikalisch Technische Bundesanstalt
'http://www.ptb.de/deutsch/org/4/43/432/oste.htm
Dim K, M, S, a, D, R, OG, SZ, OE, OS As Integer
K = Jahr \ 100
M = 15 + ((3 * K + 3) \ 4) - ((8 * K + 13) \ 25)
S = 2 - ((3 * K + 3) \ 4)
a = Jahr Mod 19
D = (19 * a + M) Mod 30
R = (D \ 29) + ((D \ 28) - (D \ 29)) * (a \ 11)
OG = 21 + D - R ' Märzdatum des Ostervollmonds (= 14. Tag des ersten Monats im Mondkalender, genannt Nisanu)
SZ = 7 - ((Jahr + (Jahr \ 4) + S) Mod 7) ' - Datum des 1. Sonntags im März
OE = 7 - ((OG - SZ) Mod 7)
OS = OG + OE
Ostern = DateSerial(Jahr, 3, OS)
End Function
Public Function Wochenende(Datum As Date) As Date
Wochenende = Weekday(Datum, vbMonday) > 5
End Function
Public Function Neujahr(Jahr As Integer) As Date
Neujahr = DateSerial(Jahr, 1, 1)
End Function
Public Function Valentinstag(Jahr As Integer) As Date
Valentinstag = DateSerial(Jahr, 2, 14)
End Function
Public Function WeiberFastnacht(Jahr As Integer) As Date
WeiberFastnacht = Ostern(Jahr) - 52
End Function
Public Function RosenMontag(Jahr As Integer) As Date
RosenMontag = Ostern(Jahr) - 48
End Function
Public Function AscherMittwoch(Jahr As Integer) As Date
AscherMittwoch = Ostern(Jahr) - 46
End Function
Public Function Karfreitag(Jahr As Integer) As Date
Karfreitag = Ostern(Jahr) - 2
End Function
Public Function OsterSonntag(Jahr As Integer) As Date
OsterSonntag = Ostern(Jahr)
End Function
Public Function OsterMontag(Jahr As Integer) As Date
OsterMontag = Ostern(Jahr) + 1
End Function
Public Function TagDerArbeit(Jahr As Integer) As Date
TagDerArbeit = DateSerial(Jahr, 5, 1)
End Function
Public Function ChristiHimmelfahrt(Jahr As Integer) As Date
ChristiHimmelfahrt = Ostern(Jahr) + 39
End Function
Public Function PfingstSonntag(Jahr As Integer) As Date
PfingstSonntag = Ostern(Jahr) + 49
End Function
Public Function PfingstMontag(Jahr As Integer) As Date
PfingstMontag = Ostern(Jahr) + 50
End Function
Public Function Fronleichnahm(Jahr As Integer) As Date
Fronleichnahm = Ostern(Jahr) + 60
End Function
Public Function NationalFeiertag(Jahr As Integer) As Date
NationalFeiertag = DateSerial(Jahr, 10, 3)
End Function
Public Function Allerheiligen(Jahr As Integer) As Date
Allerheiligen = DateSerial(Jahr, 11, 1)
End Function
Public Function HeiligAbend(Jahr As Integer) As Date
HeiligAbend = DateSerial(Jahr, 12, 24)
End Function
Public Function Advent(Jahr As Integer, Number As Integer) As Date
Advent = HeiligAbend(Jahr) - 28 - Weekday(HeiligAbend(Jahr), vbMonday) + Number * 7
End Function
Public Function ErsterWeihnachtstag(Jahr As Integer) As Date
ErsterWeihnachtstag = DateSerial(Jahr, 12, 25)
End Function
Public Function ZweiterWeihnachtstag(Jahr As Integer) As Date
ZweiterWeihnachtstag = DateSerial(Jahr, 12, 26)
End Function
Public Function Silvester(Jahr As Integer) As Date
Silvester = DateSerial(Jahr, 12, 31)
End Function
Public Function Feiertag(Datum As Date) As Date
'Berechnet ob Datum ein gesetzlicher Feiertag ist.
Dim Frei As Boolean
Dim Jahr As Integer
Jahr = Year(Datum)
Frei = (Datum = Neujahr(Jahr))
'Frei = Frei Or (Datum = WeiberFastnacht(Jahr))
'Frei = Frei Or (Datum = RosenMontag(Jahr))
'Frei = Frei Or (Datum = AscherMittwoch(Jahr))
Frei = Frei Or (Datum = Karfreitag(Jahr))
'Frei = Frei Or (Datum = OsterSonntag(Jahr))
Frei = Frei Or (Datum = OsterMontag(Jahr))
Frei = Frei Or (Datum = TagDerArbeit(Jahr))
Frei = Frei Or (Datum = ChristiHimmelfahrt(Jahr))
'Frei = Frei Or (Datum = PfingstSonntag(Jahr))
Frei = Frei Or (Datum = PfingstMontag(Jahr))
Frei = Frei Or (Datum = Fronleichnahm(Jahr))
Frei = Frei Or (Datum = NationalFeiertag(Jahr))
Frei = Frei Or (Datum = Datum = Allerheiligen(Jahr))
'Frei = Frei Or (Datum = Heiligabend(Jahr))
Frei = Frei Or (Datum = ErsterWeihnachtstag(Jahr))
Frei = Frei Or (Datum = ZweiterWeihnachtstag(Jahr))
Frei = Frei Or (Datum = Silvester(Jahr))
Feiertag = Frei
End Function
Public Function FeiertagOderWochenende(Datum As Date) As Boolean
'Samstag, Sonntag oder Feiertag.
FeiertagOderWochenende = Feiertag(Datum) Or Wochenende(Datum)
End Function
Public Function FeiertagName(Datum As Date) As String
'Name des Feiertages, falls Datum Feiertag ist, sonst "".
Dim Jahr As Integer
Jahr = Year(Datum)
If Datum = Neujahr(Jahr) Then FeiertagName = "Neujahr"
If Datum = Valentinstag(Jahr) Then FeiertagName = "Valentinstag"
If Datum = WeiberFastnacht(Jahr) Then FeiertagName = "Weiber Fastnacht"
If Datum = RosenMontag(Jahr) Then FeiertagName = "Rosenmontag"
If Datum = AscherMittwoch(Jahr) Then FeiertagName = "Aschermittwoch"
If Datum = Karfreitag(Jahr) Then FeiertagName = "Karfreitag"
If Datum = OsterSonntag(Jahr) Then FeiertagName = "Ostersonntag"
If Datum = OsterMontag(Jahr) Then FeiertagName = "Ostermontag"
If Datum = TagDerArbeit(Jahr) Then FeiertagName = "Tag der Arbeit"
If Datum = ChristiHimmelfahrt(Jahr) Then FeiertagName = "Christi Himmelfahrt"
If Datum = PfingstSonntag(Jahr) Then FeiertagName = "Pfingst Sonntag"
If Datum = PfingstMontag(Jahr) Then FeiertagName = "Pfingst Montag"
If Datum = Fronleichnahm(Jahr) Then FeiertagName = "Fronleichnahm"
If Datum = NationalFeiertag(Jahr) Then FeiertagName = "National Feiertag"
If Datum = Allerheiligen(Jahr) Then FeiertagName = "Allerheiligen"
If Datum = Advent(Jahr, 1) Then FeiertagName = "1. Advent"
If Datum = Advent(Jahr, 2) Then FeiertagName = "2. Advent"
If Datum = Advent(Jahr, 3) Then FeiertagName = "3. Advent"
If Datum = Advent(Jahr, 4) Then FeiertagName = "4. Advent"
If Datum = HeiligAbend(Jahr) Then FeiertagName = "Heiligabend"
If Datum = ErsterWeihnachtstag(Jahr) Then FeiertagName = "1. Weihnachtstag"
If Datum = ZweiterWeihnachtstag(Jahr) Then FeiertagName = "2. Weihnachtstag"
If Datum = Silvester(Jahr) Then FeiertagName = "Silvester"
End Function
Public Function MonatName(ByVal Monat As Integer) As String
'Name des Monats 1=Jan...12=Dez.
Select Case Monat Mod 12
Case 1: MonatName = "Januar"
Case 2: MonatName = "Februar"
Case 3: MonatName = "März"
Case 4: MonatName = "April"
Case 5: MonatName = "Mai"
Case 6: MonatName = "Juni"
Case 7: MonatName = "Juli"
Case 8: MonatName = "August"
Case 9: MonatName = "September"
Case 10: MonatName = "Oktober"
Case 11: MonatName = "November"
Case 0: MonatName = "Dezember"
End Select
End Function
Public Function TagName(ByVal Tag As Integer) As String
'Name des Wochentages 1=Mon...7=Sonntag
Select Case Tag Mod 7
Case 1: TagName = "Montag"
Case 2: TagName = "Dienstag"
Case 3: TagName = "Mittwoch"
Case 4: TagName = "Donnerstag"
Case 5: TagName = "Freitag"
Case 6: TagName = "Samstag"
Case 0: TagName = "Sonntag"
End Select
End Function
Public Function dinKalenderWoche(Optional Datum As Date = 0) As Integer
'cït 23/98 S.290ff
'DIN 1355
'Standard für Datum ist Aktuelles Datum
Dim KW As Integer
If Datum = 0 Then Datum = Date
KW = Int((Datum - DateSerial(Year(Datum), 1, 1) + ((Weekday(DateSerial(Year(Datum), 1, 1)) + 1) Mod 7) - 3) / 7) + 1
If KW = 0 Then
KW = dinKalenderWoche(DateSerial(Year(Datum) - 1, 12, 31))
ElseIf KW = 53 And (Weekday(DateSerial(Year(Datum), 12, 31)) - 1) Mod 7 <= 3 Then
KW = 1
End If
dinKalenderWoche = KW
End Function
Function Erstelle_Kalender(ByRef Sheet As Worksheet, ByVal Jahr As Integer, Optional ScreenUpdate As Boolean = False)
'Erstellt einen Jahreskalender für das angegebene Jahr in der Tabelle Sheet.
'Die Inhalte der Tag werden nicht geändert, das ist wichtig damit man
'den Kalender mit der Funktion neu formatieren kann.
'ScreenUpdate: Neue Anzeige nach jedem neu erstelltem Monat.
Dim Datum As Date
Dim Monat, Tag, Zeile, Spalte, Index, LastDay As Integer
Dim BColor As Long
Dim Cell As Range
Dim Expression, Comment, Zelle As String
If Jahr < 1900 Or Jahr > 9999 Then
Jahr = Year(Now())
End If
OJahr = Jahr
Application.StatusBar = "Erstelle Jahreskalender " & Jahr
Application.ScreenUpdating = False
With Sheet
.Unprotect
.Activate
.Name = Jahr
' Zunächst werden hier alle Inhalte gelöscht !!!
.Range("A2:AK38").Clear
.Range("B1:AK1").Clear
With .Range("A1:AK38")
'.Clear ' Würde auch das Jahr löschen !!!
.ClearFormats
.Font.Color = RGB(0, 0, 0)
.Borders.LineStyle = xlContinuous
.BorderAround Weight:=xlThick, Color:=RGB(0, 0, 0)
.Locked = True ' erstmal alle sperren, die Tage werden später frei gegeben
.VerticalAlignment = xlVAlignCenter
End With
With .Range("A1:A38")
.Font.Size = 9
.Font.FontStyle = "Bold"
End With
With .Range("A1:AK1")
.RowHeight = 25
.Font.Size = 9
.Font.FontStyle = "Bold"
.HorizontalAlignment = xlHAlignCenter
.Interior.Color = RGB(0, 255, 255) 'cyan
End With
With .Range("B2:AK38")
.RowHeight = 12
.Font.Size = 5.5
.Interior.Color = RGB(255, 255, 255) ' white
End With
With .Range("B2:B38,E2:E38,H2:H38,K2:K38,N2:N38,Q2:Q38,T2:T38,W2:W38,Z2:Z38,AC2:AC38,AF2:AF38,AI2:AI38")
.NumberFormat = "d"
.ColumnWidth = 0.9
.ClearComments
End With
With .Range("C2:C38,F2:F38,I2:I38,L2:L38,O2:O38,R2:R38,U2:U38,X2:X38,AA2:AA38,AD2:AD38,AG2:AG38,AJ2:AJ38")
.NumberFormat = "General"
.ColumnWidth = 7.4
End With
With .Range("D2:D38,G2:G38,J2:J38,M2:M38,P2:P38,S2:S38,V2:V38,Y2:Y38,AB2:AB38,AE2:AE38,AH2:AH38,AK2:AK38")
.ColumnWidth = 0.9
End With
With .Range("B2:D38,E2:G38,H2:J38,K2:M38,N2:P38,Q2:S38,T2:V38,W2:Y38,Z2:AB38,AC2:AE38,AF2:AH38,AI2:AK38")
.Borders(xlInsideVertical).LineStyle = xlNone
End With
With .Range("A1")
.ColumnWidth = 9.5
.Font.Size = 20
.Value = Jahr
End With
For Tag = 1 To 37
BColor = RGB(0, 255, 255) ' cyan
If (Tag - 1) Mod 7 > 4 Then
BColor = RGB(255, 255, 0) ' yellow
End If
With Cells(Tag + 1, 1)
.Value = TagName(Tag)
.Interior.Color = BColor
End With
Next Tag
For Monat = 1 To 12
Spalte = 3 * Monat - 1
Datum = DateSerial(Jahr, Monat, 1)
Index = Weekday(Datum, vbMonday)
LastDay = Day(DateSerial(Jahr, Monat + 1, 1) - 1)
'Fehler beim Zusammenfügen verhindern: Überflüssige Zellen leeren
.Range(Cells(1, Spalte), Cells(38, Spalte)).ClearContents
.Range(Cells(1, Spalte + 2), Cells(38, Spalte + 2)).ClearContents
With .Range(Cells(1, Spalte), Cells(Index, Spalte + 2))
.Merge (True)
.Interior.Color = RGB(0, 255, 255) 'cyan
End With
With .Range(Cells(Index + 1, Spalte + 1), Cells(Index + LastDay, Spalte + 2))
.Merge (True)
.Locked = False
End With
If Index + LastDay < 38 Then
With .Range(Cells(Index + LastDay + 1, Spalte), Cells(38, Spalte + 2))
.Merge (True)
.Interior.Color = RGB(0, 255, 255) 'cyan
End With
End If
If ScreenUpdate Then Application.ScreenUpdating = True
Application.StatusBar = "Erstelle Jahreskalender " & Jahr & " ( " & MonatName(Monat) & ")"
If ScreenUpdate Then Application.ScreenUpdating = False
Cells(1, Spalte).Value = MonatName(Monat)
For Tag = 1 To LastDay
Comment = FeiertagName(Datum)
With Cells(Index + Tag, Spalte)
.Value = Datum
If Comment <> "" Then .AddComment (Comment)
End With
With .Range(Cells(Index + Tag, Spalte), Cells(Index + Tag, Spalte + 2))
If FeiertagOderWochenende(Datum) Then
.Interior.Color = RGB(255, 255, 0)
End If
End With
If Weekday(Datum, vbMonday) = 1 Or Day(Datum) = 1 Then
Cells(Index + Tag, Spalte + 1).MergeArea.UnMerge
With Cells(Index + Tag, Spalte + 2)
.NumberFormat = "0"
.Value = dinKalenderWoche(Datum)
.Locked = True
End With
End If
If Comment <> "" Then
With Cells(Index + Tag, Spalte + 1)
.Font.Color = RGB(64, 64, 64) ' light-gray
.Font.Size = 4.5
If .Value = Empty Then .Value = Comment 'Alte Werte erhalten
End With
End If
Datum = Datum + 1
Next Tag
Next Monat
'.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
End With
Application.ScreenUpdating = True
Application.StatusBar = Null
End Function
Public Function CodeName2Worksheet(Name As String) As Worksheet
Dim Index As Integer
Set CodeName2Worksheet = Nothing
For Index = 1 To Worksheets.Count
If Worksheets(Index).CodeName = Name Then
Set CodeName2Worksheet = Worksheets(Index)
Exit Function
End If
Next Index
End Function
Function SetzeJahr(j As Integer)
'Den Wert der Zelle Jahr bei Öffnen der Datei merken!
'Diese funktion wird beim Öffnen der Datei automatisch aufgerufen.
OJahr = j
End Function
Public Function TesteJahr()
Dim Eingabe As Variant
Eingabe = Range("Jahr").Value
If Eingabe <> OJahr Then
If Eingabe <= 1900 Or Eingabe > 9999 Then
Range("Jahr").Value = OJahr
MsgBox ("Für die Eingabe eines neuen Jahres sind nur nur die Jahre zwischen 1900 und 9999 erlaubt (" & Eingabe & ").")
ElseIf MsgBox("Der Kalender muß neu erstellt werden.", vbOKCancel, "Das Jahr wurde geändert!") = vbOK Then
Kontext_Erstelle_Kalender
Else
MsgBox ("Änderung wird rückgängig gemacht.")
Range("Jahr").Value = OJahr
End If
End If
End Function
Public Function Kontext_Erstelle_Kalender()
Dim Index As Integer
If InStr(ActiveSheet.CodeName, "Kalender") > 0 Then
Erstelle_Kalender Sheet:=ActiveSheet, Jahr:=Names.Item("Jahr").RefersToRange.Value
End If
End Function
'© Marcus Börger 1999-2002
'
' http://www.marcus-boerger.de/?tools/zeit/
'
'Alle hier vorgestellten VisualBasic for Applications ((tm) Microsoft)
'dürfen privat und komerziell benutzt werden, wenn die Verweise und
'Kommentare auf mich unverändert bleiben!
'Dies gilt insbesondere auch dann, wenn der Sourcecode verändert wird.
'Hierzu bitte im Einzelfall nachfragen.
'
Private Sub worksheet_change(ByVal target As Range)
On Error GoTo ErrorExit
'Bei Änderungen der Zelle Jahr die Funktion TesteJahr aufrufen.
If target.Column = Range("Jahr").Column And target.Row = Range("Jahr").Row Then
Call TesteJahr
End If
Exit Sub
ErrorExit:
'Name anlegen...
Range("A1").Name = "Jahr"
End Sub
© M.Börger
31.3KB