Kalender Code
16.02.2003 17:58:38
Alex
ich habe "kalender code" von archiv runter geladen:
Option Explicit
Sub Kalender_anlegen()
Dim Jahr As Integer
Dim Monat As Date, Mon As Byte
Dim i As Byte
Dim x As Integer
Dim KW As Byte
Dim KW2 As Byte
Workbooks.Add
Jahr = InputBox("Für welches Jahr wollen Sie einen Schichtplan erstellen?", _
"Jahresabfrage", IIf(Month(Date) > 9, Year(Date) + 1, Year(Date)))
Application.ScreenUpdating = False
'Monatsblätter anlegen
For Mon = 1 To 12
Monat = DateSerial(Jahr, Mon, 1)
Sheets.Add before:=Worksheets(Mon)
ActiveSheet.Name = Format(Monat, "mmm.yyyy")
[A1] = Format(Monat, "mmmm_yyyy")
[A2] = "Name, Vorname"
Columns(1).ColumnWidth = 3.43
'Datum eintragen
For i = 1 To 31
'Abfrage, ob Monat zu Ende
If Month(DateSerial(Jahr, Mon, i)) = Mon Then
Cells(i, 1 + 1) = DateSerial(Jahr, Mon, i)
Columns(i + 1).ColumnWidth = 12.43
Cells(i, 1 + 1).Orientation = 0
' *******
' Ergänzung Hajo Ziplies 31.12.02
Cells(i, 2 + 1).Value = DateSerial(Jahr, Mon, i)
Cells(i, 2 + 1).NumberFormat = "ddd"
Columns(3).ColumnWidth = 3.43
Cells(i, 2 + 1).Orientation = 0
KW2 = DINKwoche(DateSerial(Jahr, Mon, i))
If KW2 <> KW Then
KW = KW2
Cells(i, 0 + 1).Value = KW
Cells(i, 0 + 1).Orientation = 0
End If
' *******
'Wochenende markieren
If Weekday(Cells(i, 1 + 1)) = 1 Then Cells(i, 1 + 1).Interior.ColorIndex = 48
If Weekday(Cells(i, 1 + 1)) = 7 Then Cells(i, 1 + 1).Interior.ColorIndex = 15
'Feiertage
If Right(Feiertag(Cells(i, 1 + 1)), 1) <> "*" _
And Feiertag(Cells(i, 1 + 1)) <> "" Then Cells(i, 1 + 1).Interior.ColorIndex = 48
If Right(Feiertag(Cells(i, 1 + 1)), 1) = "*" And _
Cells(i, 1 + 1).Interior.ColorIndex <> 48 Then Cells(i, 2 + 1).Interior.ColorIndex = 15
End If
Next i
Next Mon
'Überflüssige Tabellenblätter löschen
Application.DisplayAlerts = False
For x = Worksheets.Count To 13 Step -1
Worksheets(x).Delete
Next x
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
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)
'Feiertage berechnen
Select Case Datum
Case Is = DateSerial(J, 1, 1)
Feiertag = "Neujahr"
Case Is = DateSerial(J, 1, 6)
Feiertag = "Dreikönig*"
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 = "Erster Mai"
Case Is = DateAdd("D", 39, O)
Feiertag = "Christi Himmelfahrt"
Case Is = DateAdd("D", 49, O)
Feiertag = "Pfingstsonntag"
Case Is = DateAdd("D", 50, O)
Feiertag = "Pfingstmontag"
Case Is = DateAdd("D", 60, O)
Feiertag = "Fronleichnam*"
Case Is = DateSerial(J, 8, 15)
Feiertag = "Maria Himmelfahrt*"
Case Is = DateSerial(J, 10, 3)
Feiertag = "Deutsche Einheit"
Case Is = DateSerial(J, 11, 22) - (DateSerial(J, 11, 18) Mod 7)
Feiertag = "Buß- und Bettag*"
Case Is = DateSerial(J, 10, 31)
Feiertag = "Reformationstag*"
Case Is = DateSerial(J, 11, 1)
Feiertag = "Allerheiligen*"
Case Is = DateSerial(J, 12, 24)
Feiertag = "Heilig Abend*"
Case Is = DateSerial(J, 12, 25)
Feiertag = "EWeihnacht"
Case Is = DateSerial(J, 12, 26)
Feiertag = "ZWeihnacht"
Case Is = DateSerial(J, 12, 31)
Feiertag = "Silvester*"
Case Else
Feiertag = ""
End Select
End Function
Function DINKwoche(Datum)
' Diese Funktion stammt von Christoph Kremer.
Dim tmp
tmp = DateSerial(Year(Datum + (8 - Weekday(Datum)) Mod 7 - 3), 1, 1)
DINKwoche = ((Datum - tmp - 3 + (Weekday(tmp) + 1) Mod 7)) \ 7 + 1
End Function
Alles ist in ordnung,aber ich brauche 5 Zellen (von1-5)frei.
Kalender soll von zelle 6 anfangen.
Ich bin ein Anfänger in Excel.
Helfen Sie Bitte!!!