Function E97 funzt nicht in E2000
12.07.2004 22:13:57
Fritz
Die nachstehende Function habe ich von H. Herbers CD (2001). In meiner anwendung mit Excel97 funktioniert alles gut - jetzt habe ich mal wieder Excel 2000 auf meinem Rechner und da bekomme ich in der ersten Zeile den Hinweis, dass ein Automatisierungsfehler vorliegt.
Kann mir vielleicht jemand mal einen Tipp geben, wie ich das in Excel2000 nzum Laufen bekomme.
Es ist recht wichtig, da wir im Büro nun (vielleicht) aufgerüstet werden.
Danke schon mal,
Fritz
Das Hochkomma vor der Function steht da bloß, weil sich sonst immer ein html-tag (glaube ich zumindestens) einschleicht. so mit in spitzen Klammer eingeschlossen, wenn ich es absenden will.
'Public 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)
'Berechnung der Feiertage
Select Case Datum
Case Is = DateSerial(J, 1, 1)
Feiertag = "Neujahr"
'If Cells(r, 3) = "Neujahr" Then Range(Cells(r, 1), Cells(r, 65)).Interior.ColorIndex = 4
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 = "Maifeiertag"
Case Is = DateAdd("D", 39, O)
Feiertag = "Himmelfahrt"
Case Is = DateAdd("D", 49, O)
Feiertag = "Pfingstsonntag"
Case Is = DateAdd("D", 50, O)
Feiertag = "Pfingstmontag"
Case Is = DateSerial(J, 10, 3)
Feiertag = "Tag der deutschen Einheit"
Case Is = DateSerial(J, 12, 24)
Feiertag = "Heilig Abend"
Case Is = DateSerial(J, 12, 25)
Feiertag = "Erster Weihnachtsfeiertag"
Case Is = DateSerial(J, 12, 26)
Feiertag = "Zweiter Weihnachtsfeiertag"
Case Is = DateSerial(J, 12, 31)
Feiertag = "Sylvester"
End Select
End Function
Sub NeuerKalendertag()
Dim r%
r = 0
Sheets("Kalender").Activate
Range("A65536").End(xlUp).Offset(1, 0).Select
r = ActiveCell.row
Cells(r, 1).FormulaR1C1 = "=R[-1]C+1"
Cells(r, 1).Copy
Cells(r, 1).PasteSpecial (xlValues)
Cells(r, 1).Copy Cells(r, 2)
Cells(r, 2).NumberFormat = "dddd"
Cells(r, 3) = "=Feiertag(RC1)"
Wochenende
End Sub
Sub KalenderAnlegen()
Dim col%, r%
col = ActiveCell.Column
r = ActiveCell.row
col = 0
r = 0
Application.ScreenUpdating = False
Loeschen
Sheets("Kalender").Activate
Range("A1").Select
Dim Start As Date
Start = "0,22916666666667000"
Do Until Start >= "0,855000"
Start = Start + "0,02083333333333330000"
col = col + 2
Cells(1, col).Value = Format(Start, "hh:mm")
Cells(1, col + 1).Value = "Bemerkungen"
Loop
[a1:b1].EntireColumn.Insert
[a1] = "Datum"
[b1] = "Wochentag"
[c1] = "Feiertag"
Dim i%, n%
n = 549
Range("A2") = Date - 56
Range("A3").Formula = "=A2+1"
Range("A3:A" & n).FillDown
Range("A2:A" & n).Copy
Range("A2:A" & n).PasteSpecial (xlPasteValues)
Columns(1).Copy Columns(2)
Range("B2:B" & n).NumberFormat = "dddd"
Range("C2").Formula = "=Feiertag(RC[-2])"
Range("C2:C" & n).FillDown
Wochenende
Sheets("Kalender").Activate
ActiveWindow.FreezePanes = False
Range("D2").Select
ActiveWindow.FreezePanes = True
Application.ScreenUpdating = True
End Sub