Betrifft Jahreskalender für 'anne'

Informationen und Beispiele zu den hier genannten Dialog-Elementen:


Excel-Version: 8.0 (Office 97)
nach unten

Betrifft: Betrifft Jahreskalender für 'anne'
von: Rudolf
Geschrieben am: 02.07.2002 - 12:31:46

Hi 'anne',

ein rudimentärer ;-) Lösungsansatz mit ein paar Makros.
Aufruf erfolgt mit Jahreskalender zB aus dem Menü von Excel

Bei Problemen einfach nachfragen.

Gruß zum Schluß
---------------


Sub Jahreskalender()
Dim strJahr As String
Dim lngNumSheets As Long
Dim intI As Integer, intJahr As Integer

strJahr = InputBox("Kalender anlegen für Jahr:", , Year(Date))
If strJahr = "" Or Not IsNumeric(strJahr) Then Exit Sub
intJahr = CInt(strJahr)

lngNumSheets = Application.SheetsInNewWorkbook
Application.SheetsInNewWorkbook = 12
Workbooks.Add
Application.SheetsInNewWorkbook = lngNumSheets
Application.DisplayAlerts = False
Application.ScreenUpdating = False

Windows(1).Caption = "Jahreskalender " & strJahr

For intI = 1 To 12
Worksheets(intI).Activate
Call MonatAnlegen(intJahr, intI)
Next intI

Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub

Private Sub MonatAnlegen(intJahr As Integer, intMonat As Integer)
Dim intI As Integer
Dim lngDate As Long

lngDate = CLng(DateSerial(intJahr, intMonat, 1))
ActiveSheet.Name = Format(lngDate, "mmmm") 'zB "Januar"

Range("A1") = "Datum"
Range("C1") = "Eintragung"
Range("D1") = "Geburtstage"
With Range("A1:D1")
With .Font
.Bold = True
.Size = 10
.ColorIndex = 6
End With
.Interior.ColorIndex = 11
End With

intI = DateSerial(intJahr, intMonat + 1, 1) - lngDate + 1
Range("A2") = lngDate
Range("A3").Formula = "=A2+1"
Range("A3:A" & intI).FillDown
Range("A2:A" & intI).Copy
Range("A2:A" & intI).PasteSpecial (xlValues)
Range("A2:A" & intI).NumberFormat = "dd.mm.yy"
Columns(1).Copy Columns(2)
Range("B1") = "Tag"
Range("B1").HorizontalAlignment = xlRight
Range("B2:B" & intI).NumberFormat = "dddd" 'zB "Samstag"

Range("C2").Select
intI = 2
Do Until IsEmpty(Cells(intI, 1))
Select Case WeekDay(Cells(intI, 1))
Case vbSaturday
Range(Cells(intI, 1), Cells(intI, 2)).Interior.ColorIndex = 40 'Orange
Case vbSunday
Range(Cells(intI, 1), Cells(intI, 2)).Interior.ColorIndex = 3 'Rot
End Select
Cells(intI, 3).Value = Feiertag(Cells(intI, 1).Value)
intI = intI + 1
Loop
ActiveSheet.UsedRange.Columns.AutoFit
End Sub

'http://home.t-online.de/home/t.igel/xlostern.htm
Private Function Feiertag(datum As Long) As String
Dim temp As Variant
Feiertag = ""
Select Case Month(datum)
Case 1
Select Case Day(datum)
Case 1
Feiertag = "Neujahr"
Case 6
Feiertag = "Heiligen 3 Könige"
End Select
Case 2 To 6
osSo = OsterSo(Year(datum))
Select Case datum
Case osSo - 48
Feiertag = "Rosenmontag"
Case osSo - 47
Feiertag = "Fasching"
Case osSo - 46
Feiertag = "Aschermittwoch"
Case osSo - 2
Feiertag = "Karfreitag"
Case osSo - 1
Feiertag = "Karsamstag"
Case osSo
Feiertag = "Ostersonntag"
Case osSo + 1
Feiertag = "Ostermontag"
Case DateSerial(Year(datum), 5, 1)
Feiertag = "Tag der Arbeit"
Case osSo + 39
Feiertag = "Christi Himmelfahrt"
Case osSo + 48
Feiertag = "Pfingstsamstag"
Case osSo + 49
Feiertag = "Pfingstsonntag"
Case osSo + 50
Feiertag = "Pfingstmontag"
Case osSo + 60
Feiertag = "Fronleichnam"
End Select
Case 8
Select Case Day(datum)
Case 15
Feiertag = "Maria Himmelfahrt"
End Select
Case 10
Select Case Day(datum)
Case 3
Feiertag = "Tag der Dt. Einheit"
End Select
Case 11
temp = DateSerial(Year(datum), 12, 25)
Select Case datum
Case DateSerial(Year(datum), 11, 1)
Feiertag = "Allerheiligen"
Case (temp - WeekDay(temp, vbMonday) - 32)
Feiertag = "Buß- und Bettag"
End Select
Case 12
Select Case Day(datum)
Case 24
Feiertag = "Heilig Abend"
Case 25
Feiertag = "1. Weihnachtsfeiertag"
Case 26
Feiertag = "2. Weihnachtsfeiertag"
Case 31
Feiertag = "Silvester"
End Select
End Select
End Function

Private Function OsterSo(jahr As Integer) As Variant
Dim d As Variant
d = (((255 - 11 * (jahr Mod 19)) - 21) Mod 30) + 21
OsterSo = DateSerial(jahr, 3, 1) + d + (d > 48) + _
6 - ((jahr + jahr \ 4 + d + (d > 48) + 1) Mod 7)
End Function

nach oben   nach unten

Re: Betrifft Jahreskalender für 'anne'
von: th.heinrich
Geschrieben am: 02.07.2002 - 12:45:15

hallo Rudolf,

von Hans habe ich mal folgende loesung erhalten.


Sub JahresKALENDER()
Dim kJahr$
    Application.ScreenUpdating = False
    kJahr = InputBox("KALENDERjahr:", , Year(Date))
    If kJahr = "" Then Exit Sub
    Worksheets("Feiertage").Range("C1") = CInt(kJahr)
    Call BlattAnlegen
    Call JahrAnlegen(kJahr)
    Call Wochenende
    Call Feiertage(ThisWorkbook.Worksheets("Feiertage"))
    Range("A1").Select
End Sub

Private Sub BlattAnlegen()
    Dim i%
    Workbooks.Add
    Application.DisplayAlerts = False
    For i = 1 To Sheets.Count - 1
        Sheets(1).Delete
    Next i
    Application.DisplayAlerts = True
    Range("A1") = "Datum"
    Range("C1") = "Eintragung"
    With Range("A1:C1")
        With .Font
            .Bold = True
            .Size = 10
            .ColorIndex = 6
        End With
        .Interior.ColorIndex = 11
    End With
End Sub

Private Sub JahrAnlegen(kJahr)
    Dim n%
    Windows(1).Caption = "JahresKALENDER " & kJahr
    ActiveSheet.Name = kJahr
    If kJahr Mod 4 = 0 Then n = 367 Else n = 366
    Range("A2") = DateSerial(kJahr, 1, 1)
    Range("A3").Formula = "=A2+1"
    Range("A3:A" & n).FillDown
    Range("A2:A" & n).Copy
    Range("A2:A" & n).PasteSpecial (xlValues)
    Columns(1).Copy Columns(2)
    Range("B2:B" & n).NumberFormat = "dddd"
    Range("B1") = "Tag"
    Range("B1").HorizontalAlignment = xlRight
End Sub


Private Sub Wochenende()
    Dim i%
    i = 2
    Do Until IsEmpty(Cells(i, 1))
        If WeekDay(Cells(i, 1)) = 7 Then
            Range(Cells(i, 1), Cells(i, 2)) _
                .Interior.ColorIndex = 40
        ElseIf WeekDay(Cells(i, 1)) = 1 Then
            Range(Cells(i, 1), Cells(i, 2)) _
                .Interior.ColorIndex = 3
        End If
        i = i + 1
    Loop
End Sub

Private Sub Feiertage(TB1 As Worksheet)
    Dim gZelle As Range
    Dim i%
    i = 1
    Do Until IsEmpty(TB1.Cells(i, 2))
        Set gZelle = Range("A:A").Find(DateValue _
            (TB1.Cells(i, 2)), LookIn:=xlFormulas)
        With gZelle
            .Interior.ColorIndex = 4
            .Offset(0, 1).Interior.ColorIndex = 4
            .NoteText TB1.Cells(i, 1)
        End With
        i = i + 1
    Loop
End Sub

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

klappt soweit gut, dass alle wochenenden markiert werden nicht jedoch die feiertage, aber das koennte ja mit Deinem beispiel loesen.

gruss thomas

nach oben   nach unten

Re: Betrifft Jahreskalender für 'anne'
von: anne
Geschrieben am: 02.07.2002 - 13:00:15

Vielen Dank für eure Hilfe, aber mit Makro ist das doch unheimlich kompliziert. Ich habe es jetzt normal über Funktionen und bedingte Formatierungen gemacht. Dies sieht auch schon ganz gut aus, aber mit dem Februar klappt noch nicht ganz, da er mir nicht anzeigt, wenn es sich um ein Schaltjahr handelt.
Und die Feiertage muss ich auch noch einbauen, aber da bin ich jetzt dran. Versuche es zumindest mal!
Aber vielleicht kannst du mir ja noch bei Februar mit dem Schaltjahr helfen.

Liebe Grüße


nach oben   nach unten

Yep, nur 'anne' wollte halt
von: Rudolf
Geschrieben am: 02.07.2002 - 13:19:59

die Monate auf 12 Sheets verteilt haben und Feiertage eintragen.

nach oben   nach unten

Jahreskalender auch vor 1900
von: WF
Geschrieben am: 02.07.2002 - 13:20:56

Hi Anne,

schau Dir mal den Jahreskalender auf
http://www.excelformeln.de/
dort bei Tips / Sonstige (8) Nr. 32
an.

nach oben   nach unten

Schaltjahr
von: Rudolf
Geschrieben am: 02.07.2002 - 13:43:08


Gibt es sicher viele Lösungen

Die Formel:
Datum(jahr;märz;1)-Datum(jahr;februar;1)

hier mit Zahlenbeispiel
=DATUM(2000;3;1)-DATUM(2000;2;1)
ergibt 29 wenn jahr ein Schaltjahr ist,
sonst eben 28

Aber guck auch mal bei der von WF genannten Website
mit den excelformeln ohne VBA, viele Tipps dort sind gut

Gruß

nach oben   nach unten

=TAG(DATUM(2000;3;0)) langt
von: WF
Geschrieben am: 02.07.2002 - 14:20:24

http://www.excelformeln.de/
nach oben   nach unten

Re: Yep, nur 'anne' wollte halt
von: th.heinrich
Geschrieben am: 02.07.2002 - 14:27:47

hi Rudolf,

sorry hab den vorgehenden thread nicht verfolgt, wollte nur eine anregung geben.

gruss thomas


nach oben   nach unten

Jahreskalender
von: anne
Geschrieben am: 02.07.2002 - 14:37:20

Vielen Dank!

Ihr seid wirklich eine große Hilfe. Bin ein gutes Stück vorwärts gekommen, zwar noch nicht fertig, aber bestimmt bald ;-)

Gruß


 nach oben

Beiträge aus den Excel-Beispielen zum Thema "Betrifft Jahreskalender für 'anne'"