Schleife ändern für Datumsmarkierung
06.07.2006 22:26:14
Picasso
Hi!
Ich habe ein nahezu perfektes Makro.
Kann mir einer helfen, die Schleife abzuändern, sodass in dem letzigen Sheet die einzelnen Datumsangaben einzeln bearbeitet werden.
Zweck soll sein, dass nicht immer die Feiertage desselben Jahres berechnet werden, sondern z. B. 24.12.2004, 24.12.2005, 25.12.2006, usw. Derzeit arbeitet das Makro nur mit einer Jahresangabe. Anbei der Code:
Option Explicit
Sub Test()
'In Tabelle1 werden die Datumstexte in Excel-Datumswerte umgewandelt und das Format umgestellt
'Sonntage rot Formatieren, Feiertage rot bzw. Grün
Dim rngDatum As Range, rngNational As Range, rngRegional As Range, Zelle As Range, Datum As Range
Dim iSoNational As Variant, iRegional As Variant, jahr As Boolean
Dim wks1 As Worksheet, wksFeiertage As Worksheet, wb1 As Workbook
Set wb1 = ActiveWorkbook ' oder workbooks("dateiname.xls")
Set wks1 = wb1.Sheets("Tabelle1")
Set wksFeiertage = wb1.Sheets("Feiertagsvorlage")
With wks1
Set rngDatum = .Range(.Cells(4, "B"), .Cells(.Rows.Count, "B").End(xlUp))
End With
iSoNational = 3 ' Colorindex, Farbe für Sonntage, nationale Feiertage
iRegional = 4 ' Colorindex, Farbe regionale Feiertage
jahr = False
For Each Zelle In rngDatum
If IsDate(Left(Zelle.Value, 10)) Then
Zelle.Value = CDate(Left(Zelle.Value, 10))
If jahr = False Then
'Jahr in Tabelle Feiertagsvorlage eintragen
wksFeiertage.Range("B1") = Year(Zelle)
wksFeiertage.Calculate
Call HolidayTable(Year(Zelle))
jahr = True
With wksFeiertage
Set rngNational = .Range(.Cells(3, "A"), .Cells(.Rows.Count, "A").End(xlUp))
Set rngRegional = .Range(.Cells(3, "B"), .Cells(.Rows.Count, "B").End(xlUp))
End With
End If
Zelle.NumberFormat = "DDD DD.MM.YYYY"
Zelle.Interior.ColorIndex = xlColorIndexNone
For Each Datum In rngRegional
If Zelle.Value = Datum.Value Then
Zelle.Interior.ColorIndex = iRegional
Exit For
End If
Next Datum
For Each Datum In rngNational
If Zelle.Value = Datum.Value Then
Zelle.Interior.ColorIndex = iSoNational
Exit For
End If
Next Datum
If WeekDay(Zelle.Value) = vbSunday Then Zelle.Interior.ColorIndex = iSoNational
End If
Next Zelle
End Sub
' erzeugt eine Liste mit den Feiertagsdaten und -namen
' für das angegebene Jahr und speichert diese in
' holidayDate() und holidayName()
Sub HolidayTable(calcYear&)
Dim holidayDate() As Date 'Liste aller Feiertagsdaten
Dim holidayName() As String 'Liste aller Feiertagsnamen
Dim easter As Date
Dim holidaysRng As Range, rowRng As Range
Dim upperleft As Range, lowerright As Range
Dim ws As Worksheet
Dim i&, Zeile As Long
If Not IsNumeric(calcYear) Then Exit Sub
If calcYear < 1900 Or calcYear > 2078 Then Exit Sub
easter = EasterDate(calcYear)
Set ws = ThisWorkbook.Sheets("Feiertagsvorlage")
' vorhandene Inhalte in Spalten A und B löschen
ws.Range("A3:B300").ClearContents
'Bundesweite Feiertage
' die Liste mit den nationalen bundesweiten Feiertagen beginnt in C3
Set upperleft = ws.[C3]
Set lowerright = ws.Cells(ws.Rows.Count, "F").End(xlUp)
Set holidaysRng = ws.Range(upperleft, lowerright)
' Schleife über alle Zeilen des Feiertagblocks
ReDim holidayDate(holidaysRng.Rows.Count - 1)
ReDim holidayName(holidaysRng.Rows.Count - 1)
i = 0
For Each rowRng In holidaysRng.Rows
If rowRng.Cells(3).Text <> "" Then
'Feiertag relativ zu Ostern
holidayDate(i) = CDate(CDbl(easter) + rowRng.Cells(3))
Else
'Feiertag mit absolutem Datum
holidayDate(i) = DateSerial(calcYear, rowRng.Cells(2), rowRng.Cells(1))
End If
holidayName(i) = rowRng.Cells(4)
i = i + 1
Next rowRng
With ws
' Feiertage eintragen
For i = 0 To UBound(holidayDate)
.Cells(i + 3, 1) = holidayDate(i)
Next i
End With
'Regionale Feiertage
' die Liste mit den regionalen Feiertagen beginnt in G3
Set upperleft = ws.[G3]
Set lowerright = ws.Cells(ws.Rows.Count, "J").End(xlUp)
Set holidaysRng = ws.Range(upperleft, lowerright)
' Schleife über alle Zeilen des Feiertagblocks
ReDim holidayDate(holidaysRng.Rows.Count - 1)
ReDim holidayName(holidaysRng.Rows.Count - 1)
i = 0
For Each rowRng In holidaysRng.Rows
If rowRng.Cells(3).Text <> "" Then
'Feiertag relativ zu Ostern
holidayDate(i) = CDate(CDbl(easter) + rowRng.Cells(3))
Else
'Feiertag mit absolutem Datum
holidayDate(i) = DateSerial(calcYear, rowRng.Cells(2), rowRng.Cells(1))
End If
holidayName(i) = rowRng.Cells(4)
i = i + 1
Next rowRng
With ws
' Feiertage eintragen
Zeile = 3
For i = 0 To UBound(holidayDate)
If holidayDate(i) <> 1 Then
.Cells(Zeile, 2) = holidayDate(i)
Zeile = Zeile + 1
End If
Next i
End With
End Sub
' berechnet das Datum von Ostern für das angegebene calcYear
' nach einem Algorithmus von Gauss (funktioniert angeblich
' bis 2078; ich habe es aber nicht überprüft)
Function EasterDate(calcYear&) As Date
Dim zr1&, zr2&, zr3&, zr4&, zr5&, zr6&, zr7&
zr1 = calcYear Mod 19 + 1
zr2 = Fix(calcYear / 100) + 1
zr3 = Fix(3 * zr2 / 4) - 12
zr4 = Fix((8 * zr2 + 5) / 25) - 5
zr5 = Fix(5 * calcYear / 4) - zr3 - 10
zr6 = (11 * zr1 + 20 + zr4 - zr3) Mod 30
If (zr6 = 25 And zr1 > 11) Or zr6 = 24 Then zr6 = zr6 + 1
zr7 = 44 - zr6
If zr7 < 21 Then zr7 = zr7 + 30
zr7 = zr7 + 7
zr7 = zr7 - (zr5 + zr7) Mod 7
If zr7 <= 31 Then
EasterDate = CDate(CStr(zr7) & ". 3. " & CStr(calcYear))
Else
EasterDate = DateValue(CStr(zr7 - 31) & ". 4. " & CStr(calcYear))
End If
End Function
Function BussundBet(jahr As Integer) As Integer
' Ermittelt den Tag des Buß- und Bettages im November
Dim i As Integer
For i = 16 To 22
If WeekDay(DateSerial(jahr, 11, i)) = vbWednesday Then
BussundBet = i
Exit Function
End If
Next
End Function