Kalenderfunktion
24.03.2020 13:16:07
Thomas
ich nutze den Kalender von Hajo in einer Userform.
Bei Auswahl schreibt er das Datum in eine Zelle.
Läuft alles prima.
Nun möchte ich den Kalender zweimal nutzen, sprich Datum auswählen in Zelle A1 und ein weiteres Datum auswählen für Zelle B1.
Wie muss ich da vorgehen bzw. was muss ich alles ändern?
Hier das Modul:
Option Explicit ' Variablendefinition erforderlich
Option Private Module ' damit Makros nicht unter dem Punkt Makro erscheinen
'**************************************************
'* H. Ziplies *
'* 13.10.12 *
'* erstellt von HajoZiplies@WEB.de *
'* http://Hajo-Excel.de *
'**************************************************
Public CoTag() As New cls_Tag ' Name für Klasseprogrammierung Tag
Public CoKW() As New cls_Kalenderwoche ' Name für Klasseprogrammierung Kalenderwoche
Public DaDatumKa As Date ' Datum Kalender Anfang
Public InI As Integer ' Schleifenvariable, Variable zum zusamenfassen Tag
Public InK As Integer ' Schleifenvariable, Variable zum zusamenfassen Kalenderwoche
Sub Start()
frm_Kalender.Show ' UserForm starten
End Sub Sub Erstellen(DaDatum As Date)
Dim InKwA As Integer ' Variable 1. Kalenderwoche im Monat
Dim InKwE As Integer ' Variable letzte Kalenderwoche im Monat
Dim LoI As Integer ' Schleifenvariable
Dim Ob_Tag As MSForms.Label ' Variable für Objekt als neues Label Tag
Dim Ob_KW As MSForms.Label ' Variable für Objekt als neues Label Kalenderwoche
Dim Ob_LaF As MSForms.Label ' Variable für Objekt als neues Label Feiertage
Dim LoZaehler As Long ' Zeile Label
Dim LoZaehlerF As Long ' Zeile Feiertage
Dim InJ As Integer ' Schleifenvariable Wochentage
Dim DaAnfang As Date ' Anfangsdatum Kalender
Dim StFeiertag As String ' Variable für Feiertag
Dim BoFeier As Boolean ' Hinweis Bundesland
Dim Ob_St As Object ' Variable Objekte
DaDatumKa = DaDatum ' merken übergebenes Datum für Klassenprogramm
LoZaehler = 1 ' Überschriftenzeile schon da
LoZaehlerF = 0 ' Überschriftenzeile schon da
InI = 0 ' Variable für Zählen der Label auf 0 für Array
' erster Tag in erster Woche
DaAnfang = DateSerial(Year(DaDatum), Month(DaDatum), 1) - _
Weekday(DateSerial(Year(DaDatum), Month(DaDatum), 1), 2) + 1
' Kalenderwoche für ersten Tag im Monat
InKwA = KALENDERWOCHE_DIN(DateSerial(Year(DaDatum), Month(DaDatum), 1))
' Kalenderwoche für letzten Tag im Monat
InKwE = KALENDERWOCHE_DIN(DateSerial(Year(DaDatum), Month(DaDatum) + 1, 1) - 1)
With frm_Kalender ' Bezug auf die UserForm
.Cbo_Jahr.Tag = 1 ' damit Erstellen bei Change nicht ausgelöst
.Cbo_Monat.Tag = 1 ' damit Erstellen bei Change nicht ausgelöst
.Scb_Monat.Tag = 1 ' damit Erstellen bei Change nicht ausgelöst
' ScrollBar auf aktuellen Wert setzen
.Scb_Monat = (Year(DaDatum) - 1900) * 12 + Month(DaDatum)
' bei allen Label Beschriftung löschen und Farbe zurücksetzen
.Cbo_Jahr = Year(DaDatum) ' ausgewähltes Jahr anzeigen in ComboBox
.Lbl_Datum = Format(DaDatum, "MMMM YYYY") ' ausgewählten Monat und Jahr anzeigen
' ausgewählten Monat anzeigen in ComboBox
.Cbo_Monat = Format(DateSerial(Year(Date), Month(DaDatum), 1), "MMMM")
For Each Ob_St In .Controls
If TypeName(Ob_St) = "Label" Then
With Ob_St
If Left(.Name, 5) = "Label" Then
.Caption = ""
.BackColor = -2147483633
End If
End With
End If
Next Ob_St
' Schleife Label
For LoI = 1 To 10 ' keine ander Lösung gefunden für Jahreswechsel
' Label Kalenderwoche erstellen im Rahmen
Set Ob_KW = .Frm_Rahmen.Controls.Add("Forms.Label.1", "Label" & LoI, True)
' Eigenschaften dem erstellten Label zuweisen
With Ob_KW
.Left = 6 ' Position links
.Top = 15 * LoZaehler + 6 ' Position oben
.Width = 25 ' Breite
.Height = 15 ' Höhe
.Font.Bold = True ' Schriftschnitt Fett
' Beschriftung mit der entsprechenden Kalenderwoche
.Caption = KALENDERWOCHE_DIN(DaAnfang + (LoI - 1) * 7)
.TextAlign = fmTextAlignRight
.Tag = .Caption
End With
ReDim Preserve CoKW(0 To InK)
Set CoKW(InK).Label = Ob_KW ' Label zur Klasse zusammenfassen
InK = InK + 1 ' Zähler für das Array Label
' Kalenderwoche
For InJ = 1 To 7
' Label Tag erstellen im Rahmen
Set Ob_Tag = .Frm_Rahmen.Controls.Add("Forms.Label.1", "Label" & LoI & InI, True)
' Eigenschaften dem erstellten Label zuweisen
With Ob_Tag
.Left = 6 + InJ * 30 ' Position links
.Top = 15 * LoZaehler + 6 ' Position oben
.Width = 25 ' Breite
.Height = 15 ' Höhe
.Tag = DaAnfang + InI ' Datum
.Caption = Day(DaAnfang + InI) ' Tag
.TextAlign = fmTextAlignRight ' Ausrichtung rechts
' Farbe Wochenende
If DaAnfang + InI = Date Then
.BackColor = 65535
End If
If Weekday(DaAnfang + InI, 2) > 5 Then
.ForeColor = 255
End If
' Farbe für Tage außerhalb des aktuellen Monats
If Month(DaAnfang + InI) Month(DaDatum) Then
.ForeColor = 8421504
End If
' Feiertag
' Feiertag nur im aktuellen Monat
'If Month(DaAnfang) = Month(DaDatum + InI) Then
StFeiertag = Feiertag(DaAnfang + InI)
'End If
If StFeiertag "" Then
.BackColor = 13434828 ' Hintergrundfarbe ändern
End If
' Label zusammenfassen
' Neudimensionierung des Array
ReDim Preserve CoTag(0 To InI)
Set CoTag(InI).Label = Ob_Tag ' Label zur Klasse zusammenfassen
InI = InI + 1 ' Zähler für das Array Label
End With
' Feiertage auflisten im 2. Rahmen
If StFeiertag "" And Month(DaAnfang + InI) = Month(DaDatum) Then
Set Ob_LaF = .Frm_Rahmen2.Controls.Add("Forms.Label.1", "LabelF" & LoZaehlerF, True)
' Eigenschaften dem erstellten Label zuweisen
With Ob_LaF ' Bezug auf das erstelle Label
.Left = 6 ' Position links
.Top = 15 * LoZaehlerF + 6 ' Position oben
.Width = 238 ' Breite
.Height = 15 ' Höhe
' Beschriftung mit Feiertag
.Caption = " " & DaAnfang + InI - 1 & " " & StFeiertag
.TextAlign = fmTextAlignLeft
.BackColor = 13434828 ' Hintergrundfarbe Grün
' prüfen ob Bundesland abhängiger Feiertag
If InStr(StFeiertag, "*") > 0 Then BoFeier = True
End With
LoZaehlerF = LoZaehlerF + 1 ' Zeilenzähler Feiertage erhöhen
End If
Next InJ
LoZaehler = LoZaehler + 1 ' Zeilenzähler Kalenderwoche erhöhen
' Schleife verlassen, wenn Montag im nächsten Monat
If Month(DaAnfang + LoI * 7) Month(DaDatum) Then Exit For
Next LoI
If BoFeier Then ' es gibt Feiertage Bundesland abhängig
Set Ob_LaF = .Frm_Rahmen2.Controls.Add("Forms.Label.1", "LabelF" & LoZaehlerF + 1, True)
' Eigenschaften dem erstellten Label zuweisen
With Ob_LaF ' Bezug auf das erstellte Label
.Left = 6 ' Position links
.Top = 15 * LoZaehlerF + 6 ' Position oben
.Width = 238 ' Breite
.Height = 15 ' Höhe
' Hinweis Feiertag
.Caption = ""
.TextAlign = fmTextAlignLeft ' Ausrichtung
.BackColor = 13434828 ' Hintergrundfarbe Grün
End With
LoZaehlerF = LoZaehlerF + 1
End If
' Rahmenhöhe Rahmen2
.Frm_Rahmen.Height = 15 * LoZaehler + 16
If LoZaehlerF = 0 Then
.Frm_Rahmen2.Height = 0 ' Rahmenhöhe 0, da kein Eintrag
Else
' Rahmenhöhe und Position Rahmen2
.Frm_Rahmen2.Height = 15 * LoZaehlerF + 16
.Frm_Rahmen2.Top = .Frm_Rahmen.Height + 65
End If
' UserFormhöhe
.Height = .Frm_Rahmen.Height + .Frm_Rahmen2.Height + 95
.Cbo_Jahr.Tag = "" ' zurücksetzen damit Erstellen bei Change ausgelöst wird
.Cbo_Monat.Tag = "" ' zurücksetzen damit Erstellen bei Change ausgelöst wird
.Scb_Monat.Tag = "" ' zurücksetzen damit Erstellen bei Change ausgelöst wird
End With
Set Ob_Tag = Nothing ' Variablen leeren
Set Ob_LaF = Nothing ' Variablen leeren
End Sub Function KALENDERWOCHE_DIN(Datum As Date) As Integer
' von Christoph Kremer, Aachen
' Berechnt die KW nach DIN 1355
Dim t&
t = DateSerial(Year(Datum + (8 - Weekday(Datum)) Mod 7 - 3), 1, 1)
KALENDERWOCHE_DIN = (Datum - t - 3 + (Weekday(t) + 1) Mod 7) \ 7 + 1
End Function Function Feiertag(Datum As Date) As String
' der Code ist aus dem Internet, die Quelle ist mir nicht mehr bekannt
Dim J As Integer, D As Integer
Dim O As Date
J = Year(Datum)
'Osterberechnung
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)
' Feiertage berechnen
' Feiertage je Bundesland anpassen
Select Case Datum
Case DateSerial(J, 1, 1)
Feiertag = "Neujahr"
Case DateAdd("D", -2, O)
Feiertag = "Karfreitag"
Case O
Feiertag = "Ostersonntag"
Case DateAdd("D", 1, O)
Feiertag = "Ostermontag"
Case DateSerial(J, 5, 1)
Feiertag = "Erster Mai"
Case DateAdd("D", 39, O)
Feiertag = "Christi Himmelfahrt"
Case DateAdd("D", 49, O)
Feiertag = "Pfingstsonntag"
Case DateAdd("D", 50, O)
Feiertag = "Pfingstmontag"
Case DateSerial(J, 10, 3)
If Datum > "01.01.1990" Then
Feiertag = "Deutsche Einheit"
Else
Feiertag = ""
End If
Case DateSerial(J, 10, 31)
Feiertag = "Reformationstag"
Case DateSerial(J, 12, 24)
Feiertag = "Heilig Abend"
Case DateSerial(J, 12, 25)
Feiertag = "1. Weihnachtstag"
Case DateSerial(J, 12, 26)
Feiertag = "2. Weihnachtstag"
Case DateSerial(J, 12, 31)
Feiertag = "Silvester"
Case Else
Feiertag = ""
End Select
End Function
Das Klassenmodul:
Option Explicit ' Variablendefinition erforderlich
'**************************************************
'* H. Ziplies *
'* 13.10.12 *
'* erstellt von HajoZiplies@WEB.de *
'* http://Hajo-Excel.de *
'**************************************************
Public WithEvents Label As MSForms.Label
Private Sub Label_Click()
Worksheets("Fahrzeugbegleitkarte").Range("C7").Value = CInt(Label.Tag) ' _
Tag in Zelle
Worksheets("Fahrzeugbegleitkarte").Range("C7").NumberFormat = """KW"" 00" ' _
Zellformat Standard
UserForm3.TextBox31.Text = Worksheets("Fahrzeugbegleitkarte").Range("C7")
Unload frm_Kalender ' UserForm verlassen
End Sub
und
Option Explicit ' Variablendefinition erforderlich
'**************************************************
'* H. Ziplies *
'* 13.10.12 *
'* erstellt von HajoZiplies@WEB.de *
'* http://Hajo-Excel.de *
'**************************************************
Public WithEvents Label As MSForms.Label
Private Sub Label_Click()
If Month(Label.Tag) = Month(DaDatumKa) Then
Worksheets("Fahrzeugbegleitkarte").Range("C7").Value = DateValue(Label.Tag) _
' Tag in Zelle
Worksheets("Fahrzeugbegleitkarte").Range("C7").NumberFormat = "dd.mm.yyyy" ' _
Zellformat Standard
UserForm3.TextBox31.Text = Worksheets("Fahrzeugbegleitkarte").Range("C7")
Unload frm_Kalender ' UseerForm verlassen
Else
Erstellen Label.Tag ' ausgewählten Monat anzeigen
End If
End Sub