Hilfe bei folgendem Code
19.11.2003 19:43:17
Martin B
Kann mir jemand bei folgendem Code behilflich sein?
Ich möchte das in meiner tabelle auch der 1 bis 4 Advent
und der Buß & Bettag eingetragen wird. Ich habe schon viel versucht es umzuschreiben bekomme es aber nicht hin.
Auch gebe ich zu das dieser Code nicht von mir ist, leider bin ich kein so großer Profi.
Ich hoffe es kann mir jemand helfen, vielen Dank schon im voraus.
Sub Start()
ErstIndex = True
Color = 40 'Farbcode für freie Tage
Sheets("Kalender").Select
JJJJ = Val(InputBox("Bitte das gewünschte Jahr (JJJJ) eingeben", "Jahreseingabe"))
If JJJJ = 0 Then Exit Sub
If JJJJ < 1900 Then
MsgBox "Jahr muß >= 1900 sein"
Exit Sub
End If
Application.ScreenUpdating = False
Cells(1, 1) = JJJJ
'Löschen der bisherigen variablen Inhalte
Range("b4:ak34").Interior.ColorIndex = xlNone
For t = 2 To 36 Step 3
Range(Cells(4, t + 2), Cells(34, t + 2)).ClearContents
Next t
If (Cells(1, 1) Mod 4) = 0 Then
Cells(31, 6).Copy Cells(32, 6)
Else
Cells(32, 6) = ""
End If
'Setzen der Hintergrundfarben und Texte für freie Tage und sonstige Feiertage
Ostern = OsterSonntag(JJJJ)
For z = 4 To 34
For t = 4 To 34
For s = 3 To 36 Step 3
WT = Weekday(Cells(z, s))
Zellenwert = Cells(z, s)
If IsEmpty(Cells(z, s)) Then
GoTo Nächste_stz
End If
'Wochenende
Select Case WT
Case 1
With Range(Cells(z, s + 1), Cells(z, s)).Interior
.ColorIndex = 38
.Pattern = xlSolid
End With
End Select
Select Case WT
Case 7
With Range(Cells(z, s + 1), Cells(z, s)).Interior
.ColorIndex = 36
.Pattern = xlSolid
End With
End Select
'Feiertage
Select Case Zellenwert
'Bewegliche Feiertage "für Fronleichnam gilt Ostern + 60"
Case Ostern - 2
Beschriftung = "Karfreitag"
AF = 1
Feiertag
Case Ostern
Beschriftung = "Ostersonntag"
AF = 1
Feiertag
Case Ostern + 1
Beschriftung = "Ostermontag"
AF = 1
Feiertag
Case Ostern + 39
Beschriftung = "Chr.Himmelfahrt"
AF = 1
Feiertag
Case Ostern + 50
Beschriftung = "Pfingstmontag"
AF = 1
Feiertag
Case Ostern - 46
Beschriftung = "Aschermittwoch"
AF = 0
Feiertag
Case Ostern - 48
Beschriftung = "Rosenmontag"
AF = 0
Feiertag
'Feste Feiertage
Case DateSerial(JJJJ, 1, 1)
Beschriftung = "Neujahr"
AF = 1
Feiertag
Case DateSerial(JJJJ, 5, 1)
Beschriftung = "Maifeiertag"
AF = 1
Feiertag
Case DateSerial(JJJJ, 10, 3)
Beschriftung = "Tag der Einheit"
AF = 1
Feiertag
Case DateSerial(JJJJ, 10, 31)
Beschriftung = "Reformationstag"
AF = 1
Feiertag
Case DateSerial(JJJJ, 12, 25)
Beschriftung = "1.Weihnachtstag"
AF = 1
Feiertag
Case DateSerial(JJJJ, 12, 26)
Beschriftung = "2.Weihnachtstag"
AF = 1
Feiertag
Case DateSerial(JJJJ, 12, 24)
Beschriftung = "Hl.Abend"
AF = 0
Feiertag
Case DateSerial(JJJJ, 12, 31)
Beschriftung = "Silvester"
AF = 0
Feiertag
End Select
Nächste_stz:
Next s
Next t
Next z
Application.ScreenUpdating = True
Range("B4").Select
ErstIndex = False
End Sub
Anzeige