Feiertage in Kalender eintragen

[Rabe]

Hi,

zum Eintragen der Feiertagsnamen in diesen Kalender

  Urlaubskalender mit Ferien - Forum.xlsb (Größe: 55,08 KB / Downloads: 24)

benutze ich folgenden Code:

Code:

Option Explicit
Public strWert As String

Sub Eintrag_Feiertag()
  'erst werden alle Zellen gelöscht
  Range("E3:E39,L3:L39,S3:S39,Z3:Z39,AG3:AG39,AN3:AN39,E43:E79,L43:L79,S43:S79,Z43:Z79,AG43:AG79,AN43:AN79").Select
  Selection.Interior.ColorIndex = 0  '2
  Selection.ClearContents
 
  Range("F3").Select
 
  'Eintragen der Feiertage
  Dim LoZeile As Long
  Dim LoSpalte As Long
  For LoZeile = 3 To 39
     For LoSpalte = 3 To 38 Step 7
        If Cells(LoZeile, LoSpalte) <> "" Then
           strWert = Feiertag(Cells(LoZeile, LoSpalte))
           If strWert <> "" Then Cells(LoZeile, LoSpalte).Offset(0, 2) = strWert
        End If
     Next LoSpalte
  Next LoZeile
  For LoZeile = 43 To 79
     For LoSpalte = 3 To 38 Step 7
        If Cells(LoZeile, LoSpalte) <> "" Then
           strWert = Feiertag(Cells(LoZeile, LoSpalte))
           If strWert <> "" Then Cells(LoZeile, LoSpalte).Offset(0, 2) = strWert
        End If
     Next LoSpalte
  Next LoZeile
 
End Sub

Function Feiertag(Datum As Date) As String
  Dim j%, D%
  Dim O As Date
  j = Year(Range("B1"))
  '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 DateSerial(j, 1, 1)
     Feiertag = "Neujahr"
  Case DateSerial(j, 1, 6)
     Feiertag = "Dreikönig"
     '      Case DateAdd("D", -52, O)
     '         Feiertag = "Weiberfastnacht"
     '      Case DateAdd("D", -48, O)
     '         Feiertag = "Rosenmontag"
     '      Case DateAdd("D", -46, O)
     '         Feiertag = "Aschermittwoch"
  Case DateAdd("D", -2, O)
     Feiertag = "Karfreitag"
  Case O
     Feiertag = "Ostersonntag"
  Case DateAdd("D", 1, O)
     Feiertag = "Ostermontag"
  Case DateSerial(j, 5, 1)
     Feiertag = "Tag der Arbeit"
  Case DateAdd("D", 39, O)
     Feiertag = "Chr. Himmelfahrt"
  Case DateAdd("D", 49, O)
     Feiertag = "Pfingstsonntag"
  Case DateAdd("D", 50, O)
     Feiertag = "Pfingstmontag"
  Case DateAdd("D", 60, O)
     Feiertag = "Fronleichnam"
  Case DateSerial(j, 10, 3)
     Feiertag = "Deutsche Einheit"
  Case DateSerial(j, 11, 1)
     Feiertag = "Allerheiligen"
  Case DateSerial(j, 12, 24)
     Feiertag = "Heiligabend"
  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

Warum wird der Text nicht in die übernächste Spalte eingetragen?

[schauan]

Hallo Ralf,

der Text wird korrekt eingetragen. Er ist nur immer "".

Ich antworte auch gleich auf die nächste Frage. Das Jahr vom Tag 2016 ist 1905. Dein Kalender ist aber 2016, und dort sollen ja die Feiertage von 2016 rein und nicht von 1905
Also, in Deiner Function ist j = Year(...) doppelt gemoppelt, weil in B1 ja schon bzw. nur das Jahr steht

[BoskoBiati]

Hallo,

außerdem reicht dieser Code für das Eintragen:

Code:

Sub Eintrag_Feiertag()
Dim rng As Range
Dim LoZeile As Long
Dim LoSpalte As Long

   'erst werden alle Zellen gelöscht
   Set rng = Range("E3:E39,L3:L39,S3:S39,Z3:Z39,AG3:AG39,AN3:AN39,E43:E79,L43:L79,S43:S79,Z43:Z79,AG43:AG79,AN43:AN79")
   rng.Interior.ColorIndex = 0  '2
   rng.ClearContents
   
   'Eintragen der Feiertage
  
   For LoZeile = 3 To 79
    If LoZeile < 40 Or LoZeile > 42 Then
      For LoSpalte = 3 To 38 Step 7
         If Cells(LoZeile, LoSpalte) <> "" Then
            strWert = Feiertag(Cells(LoZeile, LoSpalte))
            If strWert <> "" Then Cells(LoZeile, LoSpalte).Offset(0, 2) = strWert
         End If
      Next LoSpalte
    End If
   Next LoZeile
   
End Sub

[Rabe]

Hi André,

Also, in Deiner Function ist j = Year(...) doppelt gemoppelt, weil in B1 ja schon bzw. nur das Jahr steht

ok, das war's. Danke!

Das kam daher, daß ich das Makro aus einer anderen Datei genommen habe und dort stand der 1.1.2016 drin.

[Rabe]

Hi Edgar,

außerdem reicht dieser Code für das Eintragen

danke auch Dir für das Kürzen und Vereinfachen des Codes.

[Rabe]

Hi,

So, nun eine Erweiterung der Aufgaben:
Ich möchte für das Eintragen von freien Tagen eine Liste (einzelne Tage und Bereich von/bis) erstellen, die erweitert werden kann und dann soll ein Makro im Urlaubskalender an dem entsprechenden Tag in der Spalte rechts von der Feiertagsspalte (F, M, T, ...) ein U, K oder ein G eintragen.
Für weitere Namen würde ich dann weitere Spalten nach F usw. einfügen.

Liste

	A	B	C	D
2	Name	Start	Ende	Urlaub / Gleitzeit / Krank / Dienstreise
3	xxx	04.01.2016	08.01.2016	U
4	xxx	11.01.2016		G
5	xxx	10.02.2016	12.02.2016	K
6	yyyy	15.04.2016		D

Excel-Inn.de

Hajo-Excel.de

XHTML-Tabelle zur Darstellung in Foren, einschl. der neuen Funktionen ab Version 2007

Add-In-Version 21.07 einschl. 64 Bit

[schauan]

Hallo Ralf,

ich würde so vorgehen:

Code:

'Schleife ueber alle gefuellten Zeilen in Spalte B ab Zeile 2
  'Startdatum merken
    'Enddatum merken
  'Wenn nicht,
    'Enddatum = Startdatum
  'Ende Wenn neben Startdatum Enddatum steht,
  'Schleife ueber alle Daten solange Startdatum <= Enddatum
    'Suche des Startdatums im Kalender
    'Eintrag U/K/... in gefundene Zelle - offsetiert
    'Startdatum 1 Tag hochsetzen
  'Ende Schleife ueber alle Daten solange Startdatum <= Enddatum
'Ende Schleife ueber alle gefuellten Zeilen in Spalte B ab Zeile 2

[Rabe]

Hi André,

ich würde so vorgehen:

habe es jetzt mal so probiert, aber da sind noch mehr als ein Fehler drin. Der erste kommt in der Zeile
              loRow = Rows(WorksheetFunction.Find(Worksheets("Urlaubskalender"), Range("C:C"), dteStart))
"unterstützt die Eigenschaft nicht"
dann
              Worksheets("Urlaubskalender").Range("F" & loRow) = wks.Range("D" & loZeile)

Code:

Sub Eintrag_Urlaub()
  Dim rng As Range
  Dim loZeile As Long
  Dim loRow As Long
  Dim loSpalte As Long
  Dim loLetzte As Long
  Dim wks As Worksheet
  Dim dteStart As Date
  Dim dteEnde As Date
  Dim dteLauf As Date
 
  Set wks = Sheets("Liste")                                  'Eintrags-Tabelle
  loLetzte = wks.Cells(Rows.Count, 2).End(xlUp).Row          'letzte belegte Zeile in B (2)
 
  'Vorgehensweise für Urlaubseintragung
  'Schleife ueber alle gefuellten Zeilen in Spalte B ab Zeile 3
  For loZeile = 3 To loLetzte
     'Startdatum merken
     dteStart = wks.Range("B" & loZeile).Value
     'Enddatum merken
     dteEnde = wks.Range("C" & loZeile).Value
     
     'Wenn nicht,
     'Enddatum = Startdatum
     
'      MsgBox dteStart
'      MsgBox dteEnde
     
     'Schleife ueber alle Daten solange Startdatum <= Enddatum
     If Not dteEnde = 0 Then               'wie prüfe ich auf Leer?
        If dteStart <= dteEnde Then
           Do
             
              ''Ende Wenn neben Startdatum Enddatum steht,
             
              'Suche des Startdatums im Kalender
              loRow = Rows(WorksheetFunction.Find(Worksheets("Urlaubskalender"), Range("C:C"), dteStart))
             
              'Eintrag U/K/... in gefundene Zelle - offsetiert
              Worksheets("Urlaubskalender").Range("F" & loRow) = wks.Range("D" & loZeile)
             
              'Startdatum 1 Tag hochsetzen
              dteStart = dteStart + 1
              'Ende Schleife ueber alle Daten solange Startdatum <= Enddatum
           Loop Until dteStart = dteEnde
        End If
     Else
        'Suche des Startdatums im Kalender
        loRow = Rows(WorksheetFunction.Find(Worksheets("Urlaubskalender"), Range("C:C"), dteStart))
       
        'Eintrag U/K/... in gefundene Zelle - offsetiert
        Worksheets("Urlaubskalender").Range("F" & loRow) = wks.Range("D" & loZeile)
       
     End If
     'Ende Schleife ueber alle gefuellten Zeilen in Spalte B ab Zeile 2
  Next loZeile
End Sub

'Schleife ueber alle gefuellten Zeilen in Spalte B ab Zeile 2
'Startdatum merken
'Enddatum merken
'Wenn nicht,
'Enddatum = Startdatum
'Ende Wenn neben Startdatum Enddatum steht,
'Schleife ueber alle Daten solange Startdatum <= Enddatum
'Suche des Startdatums im Kalender
'Eintrag U/K/... in gefundene Zelle - offsetiert
'Startdatum 1 Tag hochsetzen
'Ende Schleife ueber alle Daten solange Startdatum <= Enddatum
'Ende Schleife ueber alle gefuellten Zeilen in Spalte B ab Zeile 2

[schauan]

Hallo Ralf,

da kommt Excel u.a. mit der Syntax des Bereiches nicht zurecht und dann willst Du die Treffer-Zeile.
statt
 loRow = Rows(WorksheetFunction.Find(Worksheets("Urlaubskalender"), Range("C:C"), dteStart))
so etwa
 loRow = WorksheetFunction.Find(Worksheets("Urlaubskalender").Range("C:C"), dteStart)).Row

/Edit/

... und Du suchst doch nicht nur in Spalte C. Also im Prinzip Range("C2:X32") oder was immer passt.

[Rabe]

Hi André,

 loRow = WorksheetFunction.Find(Worksheets("Urlaubskalender").Range("C:C"), dteStart).Row

.Find bringt: "ungültiger Bezeichner"

  Urlaubskalender mit Ferien - Forum.xlsb (Größe: 60,55 KB / Downloads: 20)

Weiterhin:

• Wie bekomme ich das hin, daß das auch für mehrere Namen funktioniert?
  
• Warum steht da eigentlich in Urlaubskalender!A1: =T50A1:T45 bzw. was bedeutet das?