Anzeige
Archiv - Navigation
656to660
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
656to660
656to660
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Inhaltsverzeichnis

Kalender / VBA

Kalender / VBA
30.08.2005 11:29:20
Michael
Hallo zusammen,
Sepp hat mit freundlicherweise einen Code zur verfügung gestellt,
der folgendes ermöglicht:
Bei Anderung der Jahreszahl mittels Drehfeld in A1 werden die
Wochentage und formatierungen der Wochenenden sowie die Feiertage
neu berechnet. Soweit ist auch alles perfekt!!!
Nun würde ich gerne aus Gestalltungsgründen den gesamten Kalender
gerne verschieben.
Die bisherige Position beginnend in B3, die neue soll jetzt in C2.
Wo, muß jetzt genau etwas geändert werden?
Ich bekomme es einfach nicht hin.
Hier Sepp´s Code:
Option Explicit

Sub jahreskalender()
Dim iCol As Integer, iMonth As Integer
Dim lRow As Long
Dim strFeiertage As String
Dim rng As Range
On Error GoTo ErrExit
With Application
.EnableEvents = False
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
With Sheets("Kalender")
With .[B4:AF86]
.ClearContents
.Interior.ColorIndex = xlNone
.Font.Bold = False
.Font.ColorIndex = xlAutomatic
On Error Resume Next
.SpecialCells(xlCellTypeComments).ClearComments
On Error GoTo ErrExit
End With
For lRow = 3 To 81
Select Case lRow
Case 3, 10, 17, 24, 31, 38, 45, 52, 59, 66, 73, 80
iMonth = iMonth + 1
.Cells(lRow, 2) = Format(DateSerial(.[A1], iMonth, 1), "MMMM YYYY")
Case 4, 11, 18, 25, 32, 39, 46, 53, 60, 67, 74, 81
For iCol = 2 To Day(DateSerial(.[A1], iMonth + 1, 0)) + 1
.Cells(lRow, iCol) = iCol - 1 & "."
.Cells(lRow + 1, iCol) = Format(DateSerial(.[A1], iMonth, iCol - 1), "ddd")
If Weekday(DateSerial(.[A1], iMonth, iCol - 1), vbMonday) > 5 Then
.Range(.Cells(lRow, iCol), .Cells(lRow + 5, iCol)).Interior.ColorIndex = 15
End If
strFeiertage = Feiertage(DateSerial(.[A1], iMonth, iCol - 1))
If strFeiertage <> "" Then
.Range(.Cells(lRow, iCol), .Cells(lRow + 1, iCol)).Font.Bold = True
.Range(.Cells(lRow, iCol), .Cells(lRow + 1, iCol)).Font.ColorIndex = 3
.Cells(lRow, iCol).AddComment (strFeiertage)
.Cells(lRow, iCol).Comment.Shape.TextFrame.AutoSize = True
End If
Next
Case Else
End Select
Next
End With
ErrExit:
With Application
.EnableEvents = True
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
End Sub


Function Feiertage(Datum As Date)
Dim J As Integer
Dim O As Date
J = Year(Datum)
O = Ostern(J)
Select Case Datum
Case Is = DateSerial(J, 1, 1)
Feiertage = "Neujahr"
Case Is = DateSerial(J, 1, 6)
Feiertage = "Dreikönig"
Case Is = O
'##Von Ostern abgeleitete Fest- und Gedenktage
Feiertage = "Ostersonntag"
Case Is = DateAdd("D", 1, O)
Feiertage = "Ostermontag"
Case Is = DateSerial(J, 5, 1)
Feiertage = "Erster Mai"
Case Is = DateAdd("D", 39, O)
Feiertage = "Christi Himmelfahrt"
Case Is = DateAdd("D", 49, O)
Feiertage = "Pfingstsonntag"
Case Is = DateAdd("D", 50, O)
Feiertage = "Pfingstmontag"
Case Is = DateAdd("D", 60, O)
Feiertage = "Fronleichnam"
Case Is = DateSerial(J, 8, 15)
Feiertage = "Maria Himmelfahrt"
Case Is = DateSerial(J, 10, 26)
Feiertage = "National Feiertag"
Case Is = DateSerial(J, 11, 1)
Feiertage = "Allerheiligen"
Case Is = DateSerial(J, 12, 8)
Feiertage = "Maria Empfängnis"
Case Is = DateSerial(J, 12, 24)
Feiertage = "Heilig Abend"
Case Is = DateSerial(J, 12, 25)
Feiertage = "Christtag"
Case Is = DateSerial(J, 12, 26)
Feiertage = "Stefanitag"
Case Is = DateSerial(J, 12, 31)
Feiertage = "Silvester"
'##Von Weihnachten abgeleitete Fest- und Gedenktage
Case Is = DateSerial(J, 12, 25) - Weekday(DateSerial(J, 12, 25), 2) - 35
Feiertage = "Volkstrauertag"
Case Is = DateSerial(J, 12, 25) - Weekday(DateSerial(J, 12, 25), 2) - 32
Feiertage = "Buss- u. Bettag"
Case Is = DateSerial(J, 12, 25) - Weekday(DateSerial(J, 12, 25), 2) - 28
Feiertage = "Totensonntag/Ewigkeitssonntag"
Case Is = DateSerial(J, 12, 25) - Weekday(DateSerial(J, 12, 25), 2) - 21
Feiertage = "1. Advent"
Case Is = DateSerial(J, 12, 25) - Weekday(DateSerial(J, 12, 25), 2) - 14
Feiertage = "2. Advent"
Case Is = DateSerial(J, 12, 25) - Weekday(DateSerial(J, 12, 25), 2) - 7
Feiertage = "3. Advent"
Case Is = DateSerial(J, 12, 25) - Weekday(DateSerial(J, 12, 25), 2)
Feiertage = "4. Advent"
Case Else
Feiertage = ""
End Select
End Function


Function Ostern(Year As Integer)
Dim D As Integer
D = (((255 - 11 * (Year Mod 19)) - 21) Mod 30) + 21
Ostern = DateSerial(Year, 3, 1) + D + (D > 48) + 6 - _
((Year + Year \ 4 + D + (D > 48) + 1) Mod 7)
End Function

Gruß
Michael

2
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Kalender / VBA
30.08.2005 12:14:35
Michael
Hallo Sepp,
schön das Du mal wieder mein Problem
lösen konntest!
Vielen Dank
Gruß
Michael
Anzeige

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige