Kalender
30.10.2003 11:52:21
Marcus
ich habe folgendes Problem:
Ich habe ein Makro aus dem Buch "VBA-Programmierung mit Excel 97" von Michael Kofler abgeschrieben, aber es funktioniert nicht.
Es handelt sich um das Makro zur Kalenderberechnung ab S. 225.
Leider läuft es nicht.
Am einfachsten ist wohl, wenn ich einstelle!?
Hier isses: Das Problem makiere ich durch XXX
Function osterdatum(Jahr) As Date
Dim ZR1%, ZR2%, ZR3%, ZR4%, ZR5%, ZR6%, ZR7%
ZR1 = Jahr Mod 19 + 1
ZR2 = Fix(Jahr / 100) + 1
ZR3 = Fix(3 * ZR2 / 4) - 12
ZR4 = Fix((8 * ZR2 + 5) / 25) - 5
ZR5 = Fix(5 * Jahr / 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
osterdatum = CDate(CStr(ZR7) & ". 3. " & CStr(Jahr))
Else
osterdatum = DateValue(CStr(ZR7 - 31) & ". 4. " & CStr(Jahr))
End If
End Function
Dim berechnungsjahr
Dim feierdatum() As Date, feiername() As String
Private Sub Feiertagstabelle(Jahr)
Dim ostern As Date
Dim feiertage As Range, zeile As Range
Dim linksoben As Range, rechtsunten As Range
Dim ftab As Worksheet
Dim i%
If Not IsNumeric(Jahr) Then Exit Sub
If Jahr < 1900 Or Jahr > 2078 Then Exit Sub
If berechnungsjahr = Jahr Then Exit Sub
ostern = osterdatum(Jahr)
Set ftab = ThisWorkbook.Sheets("Tabelle Feiertage")
Set linksoben = ftab.[A3]
For i = 1 To 300
If ftab.[d3].Offset(i, 0).Text = "" Then
Set rechtsunten = ftab.[d3].Offset(i - 1, 0)
Exit For
End If
Next
Set feiertage = ftab.Range(linksoben, rechtsunten)
ReDim feierdatum(feiertage.Rows.Count - 1)
ReDim feiername(feiertage.Rows.Count - 1)
i = 0
For Each zeile In feiertage.Rows
If zeile.Cells(3).Text <> "" Then
feierdatum(i) = CDate(CDbl(ostern) + zeile.Cells(3))
Else
feierdatum(i) = DateSerial(Jahr, zeile.Cells(2), zeile.Cells(1))
End If
feiername(i) = zeile.Cells(4)
i = i + 1
Next zeile
berechnungsjahr = Jahr
End Sub
End Sub
Function Feiertag(ByVal datum As Date)
Dim i%
If Year(datum) <> berechnungsjahr Then
Feiertagstabelle Year(datum)
End If
datum = CDate(Int(datum))
XXXFor i = 0 To UBound(feierdatum()) ' feierdatum ist nicht definiert!!!!
If datum = feierdatum(i) Then
XXX Feiertag = feiername(i): Exit Function 'feiername auch nicht!
End If
Next
Feiertag = ""
End Function
Sub Kalendererzeugen()
Application.ScreenUpdating = False
Dim Jahr, i%, Monat%, Tag%, f$
Dim ws As Worksheet
Dim start As Range
Dim d As Date
Jahr = InputBox("Für welches Jahr soll der Kalender erzeugt werden?")
If Jahr = "" Or Not IsNumeric(Jahr) Then Exit Sub
Set ws = Worksheets.Add()
ws.Name = "Kalender " & Jahr
ActiveWindow.DisplayGridlines = False
Set start = ws.[A3]
With start
.Formula = Jahr
.Font.Bold = True
.Font.Size = 18
.HorizontalAlignment = xlLeft
End With
With start.Offset(1, 0)
For i = 1 To 12
d = DateSerial(Jahr, i, 1)
.Offset(0, i - 1).Formula = Format(d, "mmmm")
Next
End With
With Range(start.Offset(1, 0), start.Offset(1, 11))
.Font.Bold = True
.Font.Size = 14
.HorizontalAlignment = xlLeft
.Borders(xlTop).Weight = xlThin
.Borders(xlBottom).Weight = xlThin
.Interior.ColorIndex = 15
.Interior.Pattern = xlSolid
.Interior.PatternColorIndex = 15
.ColumnWidth = 15
End With
For Monat = 1 To 12
For Tag = 1 To Day(DateSerial(Jahr, Monat + 1, 0))
With start.Offset(Tag + 1, Monat - 1)
d = DateSerial(Jahr, Monat, Tag)
f = Feiertag(d)
If f = "" Then
.Value = Tag
Else
.Value = f
End If
If f <> "" Or Weekday(d) = 1 Or Weekday(d) = 7 Then
.Font.Bold = True
End If
If Weekday(d) = 1 Or Weekday(d) = 7 Then
.Interior.ColorIndex = 15
.Interior.Pattern = xlSolid
.Interior.PatternColorIndex = 15
End If
End With
Next
Next
With Range(start.Offset(2, 0), start.Offset(32, 11))
.HorizontalAlignment = xlLeft
End With
End Sub
So stehts geschrieben!
Es tut mir ja auch echt leid, dass diese Nachricht so lang geworden ist.
Deshalb bedankte ich mich auch bei allen, die bis an diese Stelle gelesen haben!!!
Danke!
Für Hilfe bin noch dankbarer!
Gruß
Marcus