Feiertage in Kalender eintragen per VBA | Herbers Excel-Forum

Hallo!
Ich habe einen Jahresplaner gebastelt, bei dem ich momentan noch die Feitertage per Formel eintrage. Dies würde ich gern per VBA lösen, finde aber keinen Ansatz.
Der Kalender ist wie folgt aufgebaut:
A5=01.01.2010 / B5=freies Feld für Eintragungen / C5=01.02.2010 / D5=freie Zelle für Eintragungen / usw
A6=02.01.2010 / B6= '' / C6=02.02.2010 / D6= '' / usw
...
Die Feiertage stehen im Bereich AC5:AD18 in folgender Form:
AC5=01.01.2010 / AD5=Neujahr
...
Die Formel zum Eintragen der Termine in den Jahresplaner lautet wie folgt:
=WENN(ISTFEHLER(SVERWEIS(A5;$AC$5:$AD$18;2;0));"";SVERWEIS(A5;$AC$5:$AD$18;2;0))
Damit wird in B5 "Neujahr" eingetragen usw.
Ich möchte nun die Formel aus den Zeilen raushaben und suche daher eine Lösung per VBA. Diese sollte so gestaltet sein, dass zunächst automatisch die Feiertage eingetragen werden, wenn die Tabelle geöffnet/geändert wird. Trägt der User ein anderes Ereignis ein, dann soll dieses Vorrang haben (z.B. Eintrag in B6 "Aufräumen ;-)". Wird das Ereignis aber wieder gelöscht, dann soll wieder per VBA "Neujahr" eingetragen werden. > Ihr merkt, warum eine Formel eher unglück ist...<
Geht das? Kann mir einer helfen?
Gruß Peter

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Peter,

Function Feiertag(Datum As Date) As String
Dim J%, D%
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
Select Case Datum
Case Is = DateSerial(J, 1, 1)
Feiertag = "Neujahr"
Case Is = DateSerial(J, 1, 6)
Feiertag = "Dreikönig*"
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 = "Erster 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 = "EWeihnacht"
Case Is = DateSerial(J, 12, 26)
Feiertag = "ZWeihnacht"
Case Is = DateSerial(J, 12, 31)
Feiertag = "Silvester*"
Case Else
Feiertag = ""
End Select
End Function

Ich möchte nun die Formel aus den Zeilen raushaben und suche daher eine Lösung per VBA. Diese sollte so gestaltet sein, dass zunächst automatisch die Feiertage eingetragen werden, wenn die Tabelle geöffnet/geändert wird. Trägt der User ein anderes Ereignis ein, dann soll dieses Vorrang haben (z.B. Eintrag in B6 "Aufräumen ;-)". Wird das Ereignis aber wieder gelöscht, dann soll wieder per VBA "Neujahr" eingetragen werden. > Ihr merkt, warum eine Formel eher unglück ist...<

Case DateSerial(J, 1, 1) Feiertag = "Neujahr" Case DateSerial(J, 1, 6) Feiertag = "Dreikönig*" Case DateAdd("D", -2, O) Feiertag = "Karfreitag" Case DateSerial(J, 11, 22) - (DateSerial(J, 11, 18) Mod 7) 'usw.

Private Sub Workbook_Open() Dim lCol As Long, lRow As Long, sFT Application.ScreenUpdating = False With Sheets(1) For lCol = 1 To 23 Step 2 lRow = 5 Do While .Cells(lRow, lCol) <> "" If .Cells(lRow, lCol + 1) = "" Then .Cells(lRow, lCol + 1) = Feiertag(.Cells(lRow, lCol)) End If lRow = lRow + 1 Loop Next End With Application.ScreenUpdating = True End Sub

Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Range("B:B")) Is Nothing Then If Target.Value = "" Then Cells(Target.Row, Target.Column) = WorksheetFunction.VLookup(Cells( _ Target.Row, 1), Range("AC5:AD18"), 2, 0) End If End Sub

Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Range("B:B")) Is Nothing Then If WorksheetFunction.CountIf(Range("AC5:AC18"), Cells(Target.Row, 1)) <> 1 Then Exit Sub If Target.Value = "" Then Cells(Target.Row, Target.Column) = WorksheetFunction.VLookup(Cells(_ Target.Row, 1), Range("AC5:AD18"), 2, 0) End If End Sub

Beliebteste Forumthreads (12 Monate)

Feiertage in Kalender eintragen per VBA | Herbers Excel-Forum

21
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

310 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Feiertage in Kalender eintragen per VBA | Herbers Excel-Forum

21 Beiträge zum Forumthread Beiträge zu diesem Forumthread

310 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

21
Beiträge zum Forumthread

Beiträge zu diesem Forumthread