Zelleninhalt überprüfen und kopieren

Option Explicit

Type MyFeiertage_struct
  sDate As String
  sBez  As String
End Type

 ->Konstanten für Feiertagstabell
  Const cFT_BLTNAME = Feiertage ->Blattname
  Const cFT_SP_DATUM = 1           'Spalte A - Datum
  Const cFT_SP_BEZ = 2             'Spalte B - Feiertagsbezeichnung
  Const cFT_Z_ERSTEWERTEZEILE = 1 ->erste Zeile mit Werten
  
 ->Konstanten für Kalenderblatt
  Const cKB_SP_DATUM = 1           'Spalte A - Datum
  Const cKB_SP_BEZ = 2             'Spalte B - Feiertagsbezeichnung
  Const cKB_Z_ERSTEWERTEZEILE = 1 ->erste Zeile mit Werten
  
  Const cDATUMSFORMAT = dd.mm.yyyy->intern verwendetes Datumsformat

'************************************************************************
Sub FeiertagsbezeichnungenAusFeiertageEintragen()
 ->*** Makro überprüft alle Zellen der aktuellen Tabelle (Kalenderblatt) in der Spalte Datum,
 ->*** ob dieses Datum in der Tabelle Feiertage vorhanden ist.
 ->*** Wenn ja, wird die Feiertagsbezeichnung in das Kalennderblatt kopiert.
 ->***

  Dim wsKB As Worksheet, wb As Workbook
  Dim FT() As MyFeiertage_struct, FTCnt As Long
  Dim lKBRows As Long, dDate As Date, sDate As String, x As Long, y As Long
  
 ->aktive Mappe / aktives Blatt KB setzen
  Set wb = ActiveWorkbook
  Set wsKB = ActiveSheet
  
 ->Feiertagstabelle in Feld einlesen (Datum im Format dd.mm.yyyy)
  If Not FeiertagstabelleInFeldEinlesen(wb, FT(), FTCnt) Then GoTo AUFRAEUMEN
  
 ->Kalenderblatt-Datum auf Feiertag überprüfen
 ->ggf. Feiertagsbezeichnung eintragen
  lKBRows = wsKB.Cells(wsKB.Rows.Count, 1).End(xlUp).Row
  For x = cKB_Z_ERSTEWERTEZEILE To lKBRows
    If IsDate(wsKB.Cells(x, cKB_SP_DATUM).Value) Then
      dDate = wsKB.Cells(x, cKB_SP_DATUM).Value
      sDate = Format(dDate, cDATUMSFORMAT)
      For y = 1 To FTCnt
        If sDate = FT(y).sDate Then
          wsKB.Cells(x, cKB_SP_BEZ).Value = FT(y).sBez
          Exit For
        End If
      Next
    End If
  Next
  
AUFRAEUMEN:
  Set wsKB = Nothing: Set wb = Nothing
End Sub

'************************************************************************
Private Function FeiertagstabelleInFeldEinlesen(wb As Workbook, _
                                                FT() As MyFeiertage_struct, FTCnt As Long) As Boolean
 ->Feiertagstabelle in Feld einlesen (Datum im Format dd.mm.yyyy)
  
  Dim wsFT As Worksheet
  Dim lFTRows As Long, x As Long, dDate As Date
  
  FeiertagstabelleInFeldEinlesen = False
  
  On Error Resume Next
  Set wsFT = ActiveWorkbook.Worksheets(cFT_BLTNAME)
  On Error GoTo 0
  Err.Clear
  If wsFT Is Nothing Then
    MsgBox Tabelle  & cFT_BLTNAME &  ist nicht in der aktiven Mappe vorhanden.
    GoTo AUFRAEUMEN
  End If
  FTCnt = 0: ReDim FT(1 To 1)
  lFTRows = wsFT.Cells(wsFT.Rows.Count, 1).End(xlUp).Row
  For x = cFT_Z_ERSTEWERTEZEILE To lFTRows
    If IsDate(wsFT.Cells(x, cFT_SP_DATUM).Value) Then
      FTCnt = FTCnt + 1: ReDim Preserve FT(1 To FTCnt)
      dDate = wsFT.Cells(x, cFT_SP_DATUM).Value
      FT(FTCnt).sDate = Format(dDate, cDATUMSFORMAT)
      FT(FTCnt).sBez = wsFT.Cells(x, cFT_SP_BEZ).Value
    End If
  Next
  
  FeiertagstabelleInFeldEinlesen = True
AUFRAEUMEN:
  Set wsFT = Nothing
End Function