hallo richard,
hajo hat mal nen tollen lösungsansatz gebastelt
//kalender mit feiertagen anlegen//
[31.12.02]
Sub Kalender_anlegen()
Dim Jahr As Integer
Dim Monat As Date, Mon As Byte
Dim i As Byte
Dim x As Integer
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
' *******
'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 SubFunction 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
//aktive zelle farbig//
[03.01.03]
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Static Zelle As Range
If Not Zelle Is Nothing Then
Zelle.Interior.ColorIndex = xlNone
End If
Target.Interior.ColorIndex = 6
Set Zelle = Target
End Sub
//alle tabellen automatisch mit name aus a1 benennen//
[03.01.03]
in diese Arbeitsmappe kopieren !
dann wird dies in jedem Blatt ausgeführt !
der Name aus A1 wird als Blattname verwendet !
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
On Error GoTo Fehler
If Target.Row <> 1 Or Target.Column <> 1 Then Exit Sub
ActiveSheet.Name = Cells(1, 1).Value
Exit Sub
Fehler: MsgBox ("Tabellenname ist falsch oder bereits vergeben !")
Range("A1").Select
End Sub
gruß
andreas e
http://www.skripteundaufgaben.de viele kostenlose Downloads und Lösungsansätze zu EXCEL und mehr