Re: Kalenderwochen per VBA
31.12.2002 10:59:50
Hajo_Zi
Hallo Rolf-Dieter die Kalenderwoche war doch einfacher als gedacht. Hier der endgültige Code.
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 = 13.86
'Datum eintragen
For i = 1 To 31
'Abfrage, ob Monat zu Ende
If Month(DateSerial(Jahr, Mon, i)) = Mon Then
Cells(2, i + 1) = DateSerial(Jahr, Mon, i)
Columns(i + 1).ColumnWidth = 2.43
Cells(2, i + 1).Orientation = 90
' *******
' Ergänzung Hajo Ziplies 31.12.02
Cells(3, i + 1).Value = DateSerial(Jahr, Mon, i)
Cells(3, i + 1).NumberFormat = "ddd"
Cells(3, i + 1).Orientation = 90
KW2 = DINKwoche(DateSerial(Jahr, Mon, i))
If KW2 <> KW Then
KW = KW2
Cells(4, i + 1).Value = KW
Cells(4, i + 1).Orientation = 90
End If
' *******
'Wochenende markieren
If Weekday(Cells(2, i + 1)) = 1 Then Cells(2, i + 1).Interior.ColorIndex = 48
If Weekday(Cells(2, i + 1)) = 7 Then Cells(2, i + 1).Interior.ColorIndex = 15
'Feiertage
If Right(Feiertag(Cells(2, i + 1)), 1) <> "*" _
And Feiertag(Cells(2, i + 1)) <> "" Then Cells(2, i + 1).Interior.ColorIndex = 48
If Right(Feiertag(Cells(2, i + 1)), 1) = "*" And _
Cells(2, i + 1).Interior.ColorIndex <> 48 Then Cells(2, i + 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
Code eingefügt mit: Excel Code Jeanie
Code Jeanie
Frage
Das Umsetzen nach Html klappt perfekt, auch die Ansicht in den Foren ist gegeben. Bei manchen Foren kann man aber anscheinend nicht den dargestellten Code nach VBA rückkopieren. Warum?
Antwort
Dies liegt nicht an der Code Jeanie !!! Manche Foren interpretieren anscheinend < pre > < /pre > Tags nicht richtig und erzeugen am Zeilenende einen weichen Zeilenumbruch anstatt eines harten Zeilenumbruches. Dies führt dazu, dass im VBA-Editor die Zeilen hintereinander geschrieben werden. Zum Rückkopieren in solchen Fällen: Fügen Sie den kopierten Code aus dem Forum nach Word ein, kopieren Sie ihn dort wieder und fügen Sie ihn dann im VBA - Editor ein
Gruß Hajo