Kalender mit VBA erstellt, aber 29.02. fehlt.
07.01.2024 07:05:58
Chris135
ich möchte für meinen Arbeitgeber einen Kalender zur Urlaubsplanung erstellen.
Dazu durchlaufe ich eine For-Schleife von Anfang bis Ende des Jahres und ermittle das Datum über die DateAdd Funktion.
Leider konnte ich 2 Probleme in der Sub Kalender_erstellen noch nicht lösen:
1) der 29.02.2024 fehlt
2) ich würde gerne die einzelnen Monate auf-/zuklappbar gestalten. Mit .Range(...).Group bekomme ich eine Gruppe von Januar-Dezember und nicht jedes Monat einzeln.
Ich habe eine Beispieldatei erstellt und die zu klärenden Passagen wie folgt markiert: '**** entsprechendes Problem ****
https://www.herber.de/bbs/user/165941.xlsm
Das ist mein erster Beitrag. Falls Ihr weitere Infos benötigt, bitte einfach schreiben.
Ich konnte schon so viele Probleme durch eure Beiträge lösen, also vielen Dank an all die fleißigen Leute.
Und natürlich vielen Dank im Voraus an diejenigen, die sich meinem Problem widmen :)
Viele Grüße
Chris
hier noch der Code:
Const SNeujahr As Integer = 2 'erste Spalte des Kalenders
Const ZMonat As Integer = 2 'Zeile in der Monatsname eingetragen wird
Const ZTagInt As Integer = 3 'Zeile in der Tag eingetragen wird
Sub main()
'Ausführen, um Kalender zu erstellen
Call Urlaub_erstellen("2024")
End Sub
Sub Urlaub_erstellen(Jahr As String)
'erstellt ein neues Sheet "Urlaub "+Jahr
Dim WS As Worksheet
Dim NKalender As String: NKalender = "Urlaub " & Jahr 'Name des WS
Dim vorhanden As Boolean: vorhanden = False
'WS vorhanden?
For Each WS In ThisWorkbook.Worksheets
If WS.Name = NKalender Then vorhanden = True: Exit For
Next
With ThisWorkbook
'Wenn nicht vorhanden, dann erstellen
If Not vorhanden Then
.Sheets.Add after:=Worksheets(Worksheets.Count)
.ActiveSheet.Name = NKalender
End If
'Kalender erstellen
Call Kalender_erstellen(.Worksheets(NKalender), 2023)
End With
End Sub
Sub Kalender_erstellen(WS_Urlaub As Worksheet, Jahr As Integer)
'erstellt den Kalender für Jahr im WS_Urlaub
With WS_Urlaub
'Ursprung wiederherstellen
.Range(.Cells(1, 1), Cells(50, 400)).UnMerge
.Range(.Columns(1), .Columns(400)).ColumnWidth = 10.71
'Kalender erstellen
Dim i As Integer
Dim Datum As Date
Dim Spalte As Integer 'aktuell zu bearbeitende Spalte
Dim SmAnfang As Integer: SmAnfang = SNeujahr 'Spalte Monatsanfang
'jeden Tag des Jahres ablaufen
For i = 1 To DateDiff("D", "31.12." & Jahr - 1, "31.12." & Jahr)
Spalte = SNeujahr + i - 1
'****1) Warum erkennt er nicht 29.02.?****
Datum = DateAdd("d", CDbl(i), CDate("31.12." & CStr(Jahr - 1)))
'Tag schreiben
.Cells(ZTagInt, Spalte) = CStr(Day(Datum))
.Cells(ZTagInt + 1, Spalte) = Weekday(Datum, vbSunday)
'Wochenende einfärben
If Not Arbeitstag(Datum) Then .Range(.Cells(ZTagInt, Spalte), .Cells(ZTagInt + 3, Spalte)).Interior.Color = RGB(128, 128, 128)
'Monat schreiben (in Spalte des ersten Tages des Monats)
If Day(Datum) = 1 Then .Cells(ZMonat, Spalte) = MonthName(Month(Datum))
'Monatsname Zellen Mergen
If Day(DateAdd("d", 1, Datum)) = 1 Then
.Range(.Cells(ZMonat, SmAnfang), .Cells(ZMonat, Spalte)).Merge
'****2) Gruppieren möglich, sodass jeder Monat einzeln aufgeklappt werden kann?****
'.Range(.Cells(ZMonat, SmAnfang), .Cells(ZMonat, Spalte)).Group
SmAnfang = Spalte + 1
End If
'Spaltenbreite anpassen
.Columns(Spalte).ColumnWidth = 2.14
Next
End With
End Sub
Function Arbeitstag(Datum As Date) As Boolean
If Weekday(Datum, vbSunday) > 5 Then Arbeitstag = False: Exit Function
Arbeitstag = True
End Function