Hallo zusammen,
ich habe in einem Forum eine für mich passende automatische Kalendererstellung gefunden. Soweit habe ich schon einiges für mich angepasst.
Ich habe auf meiner Übersichtsseite einen Button erstellt. Dieser erstellt mir ein neues Tabellenblatt und führt den unten ausgeführten Code aus.
Da ich das Datum nicht immer im Code anpassen möchte, würde ich das Datum gerne auch auf der Übersichtsseite haben.
In Zelle A9 und B9
In Zelle A10 und B10
Wenn das Datum drinne steht, soll dieses in den Code übernommen werden.
Public Sub Erstellen()
Call Kalender_erstellen(ActiveSheet.Range("B1"), "01.01.16", "30.06.2016", True, True, True, 6, 6, 6, 4, 3, False, False, 1, 15)
Call Kalender_erstellen(ActiveSheet.Range("B16"), "01.07.16", "31.12.16", True, True, True, 6, 6, 6, 4, 3, False, False, 1, 15)
Für eure Hilfe wäre ich sehr dankbar :-).
Liebe Grüße
Option Explicit
Public Sub Erstellen()
Call Kalender_erstellen(ActiveSheet.Range("B1"), "01.01.16", "30.06.2016", True, True, True, 6, 6, 6, 4, 3, False, False, 1, 15)
Call Kalender_erstellen(ActiveSheet.Range("B16"), "01.07.16", "31.12.16", True, True, True, 6, 6, 6, 4, 3, False, False, 1, 15)
End Sub
Public Sub Kalender_erstellen(Startposition As Range, A_datum As Date, E_datum As Date, Feiertage As Boolean _
, Sa As Boolean, So As Boolean, zeilen_nachunten As Integer, _
Farbe_sa As Integer, Farbe_so As Integer, Farbe_feiertag As Integer, _
Spaltenbreite As Integer, Tage_ein_zweistellig As Boolean, _
KW_ein_zweistellig As Boolean, Farbe_rahmenlinie As Integer _
, zeilenhöhe As Integer)
Dim a As Date
Dim spalte As Integer
Dim zeile As Integer
Dim Pos1_kw As Integer
Dim Pos2_kw As Integer
Dim Pos1_mon As Integer
Dim Pos2_mon As Integer
Dim b As Range
spalte = Startposition.Column
zeile = Startposition.Row
Application.ScreenUpdating = False
With ThisWorkbook.ActiveSheet
' Schauen ob in dem Bereich etwas steht
For Each b In .Range(Cells(zeile, spalte), Cells(zeile + zeilen_nachunten + 3, spalte + (E_datum - A_datum)))
If b <> "" Then
Application.ScreenUpdating = True
.Range(Cells(zeile, spalte), Cells(zeile + zeilen_nachunten + 3, spalte + (E_datum - A_datum))).Select
MsgBox "Achtung in dem Bereich in dem der Kalender erstellt werden soll sind nicht alle zellen leer!", vbCritical, "Achtung"
Exit Sub
End If
Next b
' Formatierungen
.Range(Cells(zeile + 3, spalte), Cells(zeile + 3, spalte + (E_datum - A_datum))).ColumnWidth = Spaltenbreite
With .Range(Cells(zeile, spalte), Cells(zeile + zeilen_nachunten + 3, spalte + (E_datum - A_datum)))
.Borders(xlEdgeLeft).LineStyle = xlContinuous
.Borders(xlEdgeTop).LineStyle = xlContinuous
.Borders(xlEdgeBottom).LineStyle = xlContinuous
.Borders(xlEdgeRight).LineStyle = xlContinuous
.Borders(xlInsideVertical).LineStyle = xlContinuous
.Borders(xlInsideHorizontal).LineStyle = xlContinuous
.Borders.ColorIndex = Farbe_rahmenlinie
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.RowHeight = zeilenhöhe
.Borders.LineStyle = xlContinuous
.Borders.Weight = xlThin
End With
.Range(Cells(zeile + 1, spalte), Cells(zeile + 1, spalte + (E_datum - A_datum))).Borders(xlInsideVertical).LineStyle = xlNone
' Von A_datum bis E_datum
For a = A_datum To E_datum
' Formatierung wenn Datum ist ein SA oder So oder Feiertag
If Sa = True Then
If Format(a, "ddd") = "Sa" Then _
.Range(Cells(zeile + 1, spalte), Cells(zeile + zeilen_nachunten + 3, spalte)).Interior.ColorIndex = Farbe_sa
End If
If So = True Then
If Format(a, "ddd") = "So" Then _
.Range(Cells(zeile + 1, spalte), Cells(zeile + zeilen_nachunten + 3, spalte)).Interior.ColorIndex = Farbe_so
End If
If Feiertage = True Then
If Ist_feiertag(a) <> "" Then
.Range(Cells(zeile + 2, spalte), Cells(zeile + zeilen_nachunten + 3, spalte)).Interior.ColorIndex = Farbe_feiertag
' Feiertags - kommentar einfügen
Call Kommentar_formatieren(Cells(zeile + 3, spalte), Ist_feiertag(a))
End If
End If
' Kalenderwoche
If Format(a, "ddd") = "Mo" Then Pos1_kw = Cells(zeile + 1, spalte).Column
If Format(a, "ddd") = "Fr" Then Pos2_kw = Cells(zeile + 1, spalte).Column
If Format(a, "ddd") = "Fr" And Pos1_kw <> 0 Then
.Range(Cells(zeile + 1, Pos1_kw), Cells(zeile + 1, Pos2_kw)).Merge
If KW_ein_zweistellig = True Then
.Range(Cells(zeile + 1, Pos1_kw), Cells(zeile + 1, Pos2_kw)).NumberFormat = "@"
.Range(Cells(zeile + 1, Pos1_kw), Cells(zeile + 1, Pos2_kw)) = Format(kalenderwoche_D(a), "##00")
Else
.Range(Cells(zeile + 1, Pos1_kw), Cells(zeile + 1, Pos2_kw)) = Format(kalenderwoche_D(a), "#0")
End If
Pos1_kw = 0
End If
' Monat
If Day(a) = 1 Then
Pos1_mon = Cells(zeile, spalte).Column
.Range(Cells(zeile, spalte), Cells(zeile + zeilen_nachunten + 3, spalte)).Borders(xlEdgeLeft).LineStyle = xlContinuous
.Range(Cells(zeile, spalte), Cells(zeile + zeilen_nachunten + 3, spalte)).Borders(xlEdgeLeft).Weight = xlThick
End If
If Day(a) = Letzter_tag_im_monat(a) Then
Pos2_mon = Cells(zeile, spalte).Column
.Range(Cells(zeile, spalte), Cells(zeile + zeilen_nachunten + 3, spalte)).Borders(xlEdgeRight).LineStyle = xlContinuous
.Range(Cells(zeile, spalte), Cells(zeile + zeilen_nachunten + 3, spalte)).Borders(xlEdgeRight).Weight = xlThick
End If
If Day(a) = Letzter_tag_im_monat(a) And Pos1_mon <> 0 Then
.Range(Cells(zeile, Pos1_mon), Cells(zeile, Pos2_mon)).Merge
.Range(Cells(zeile, Pos1_mon), Cells(zeile, Pos2_mon)) = Format(a, "mmmm")
Pos1_mon = 0
End If
' Tag zahl z.b. 6 oder 06
If Tage_ein_zweistellig = True Then
.Cells(zeile + 3, spalte).NumberFormat = "@"
.Cells(zeile + 3, spalte) = Format(a, "dd")
Else
.Cells(zeile + 3, spalte) = Format(a, "d")
End If
' Tag wochentag c.b. Mo
.Cells(zeile + 2, spalte) = Format(a, "ddd")
spalte = spalte + 1
Next a
End With
Application.ScreenUpdating = True
End Sub
Function Ostern(Yr As Integer) As Date
Dim D As Integer
D = (((255 - 11 * (Yr Mod 19)) - 21) Mod 30) + 21
Ostern = DateSerial(Yr, 3, 1) + D + (D > 48) + 6 - _
((Yr + Yr \ 4 + D + (D > 48) + 1) Mod 7)
End Function
Public Function Ist_feiertag(Datum As Date) As String
Ist_feiertag = ""
' Ostern
If Datum = Ostern(Year(Datum)) Then Ist_feiertag = Ist_feiertag & "Ostern" & Chr(10)
' Neujahr
If Datum = DateSerial(Year(Datum), 1, 1) Then Ist_feiertag = Ist_feiertag & "Neujahr" & Chr(10)
' Maifeiertag
If Datum = DateSerial(Year(Datum), 5, 1) Then Ist_feiertag = Ist_feiertag & "Maifeiertag" & Chr(10)
' Karfreitag
If Datum = Ostern(Year(Datum)) - 2 Then Ist_feiertag = Ist_feiertag & "Karfreitag" & Chr(10)
' Ostermontag
If Datum = Ostern(Year(Datum)) + 1 Then Ist_feiertag = Ist_feiertag & "Ostermontag" & Chr(10)
' Christi Himmelfahrt
If Datum = Ostern(Year(Datum)) + 39 Then Ist_feiertag = Ist_feiertag & "Christi Himmelfahrt" & Chr(10)
' Pfingstsonntag
If Datum = Ostern(Year(Datum)) + 49 Then Ist_feiertag = Ist_feiertag & "Pfingstsonntag" & Chr(10)
' Pfingstmontag
If Datum = Ostern(Year(Datum)) + 50 Then Ist_feiertag = Ist_feiertag & "Pfingstmontag" & Chr(10)
' Fronleichnam
If Datum = Ostern(Year(Datum)) + 60 Then Ist_feiertag = Ist_feiertag & "Fronleichnam" & Chr(10)
' TagDeutscheEinheit
If Datum = DateSerial(Year(Datum), 10, 3) Then Ist_feiertag = Ist_feiertag & "Tag der Deutschen Einheit" & Chr(10)
' Tag der Arbeit
If Datum = DateSerial(Year(Datum), 5, 1) Then Ist_feiertag = Ist_feiertag & "Tag der Arbeit" & Chr(10)
' Reformationstag
If Datum = DateSerial(Year(Datum), 10, 31) Then Ist_feiertag = Ist_feiertag & "Reformationstag" & Chr(10)
' Heiligabend
'If Datum = DateSerial(Year(Datum), 12, 24) Then Ist_feiertag = Ist_feiertag & "Heiligabend" & Chr(10)
' 1. Weihnachtsfeiertag
If Datum = DateSerial(Year(Datum), 12, 25) Then Ist_feiertag = Ist_feiertag & "1. Weihnachtsfeiertag" & Chr(10)
' 2. Weihnachtsfeiertag
If Datum = DateSerial(Year(Datum), 12, 26) Then Ist_feiertag = Ist_feiertag & "2. Weihnachtsfeiertag" & Chr(10)
' Silvester
'If Datum = DateSerial(Year(Datum), 12, 31) Then Ist_feiertag = Ist_feiertag & "Silvester" & Chr(10)
' Mariä Himmelfahrt
'If Datum = DateSerial(Year(Datum), 8, 15) Then Ist_feiertag = Ist_feiertag & "Maria Himmelfahrt" & Chr(10)
' Buß- und Bettag
'If Datum = CDate("25.12." & Year(Datum)) - Weekday("25.12." & Year(Datum), vbMonday) - 32 Then Ist_feiertag = Ist_feiertag & "Buß- und Bettag" & Chr(10)
' Weiberfastnacht
'If Datum = Ostern(Year(Datum)) - 52 Then Ist_feiertag = Ist_feiertag & "Weiberfastnacht" & Chr(10)
' Rosenmontag
'If Datum = Ostern(Year(Datum)) - 48 Then Ist_feiertag = Ist_feiertag & "Rosenmontag" & Chr(10)
If Ist_feiertag <> "" Then Ist_feiertag = Left(Ist_feiertag, Len(Ist_feiertag) - 1)
End Function
Function kalenderwoche_D(Datum As Date) As Integer
''von Christoph Kremer, Aachen
'Berechnt die KW nach DIN 1355
Dim t As Date
t = DateSerial(Year(Datum + (8 - Weekday(Datum)) Mod 7 - 3), 1, 1)
kalenderwoche_D = (Datum - t - 3 + (Weekday(t) + 1) Mod 7) \ 7 + 1
End Function
Public Function Letzter_tag_im_monat(Datum As Date) As Integer
Letzter_tag_im_monat = Day(DateSerial(Year(Datum), Month(Datum) + 1, "01") - 1)
End Function
Sub Kommentar_formatieren(Bereich As Range, Text As String)
With Bereich
.ClearComments
.AddComment.Text Text:=Text
.Comment.Visible = False
.Comment.Shape.TextFrame.AutoSize = True
.Comment.Shape.TextFrame.HorizontalAlignment = xlCenter
.Comment.Shape.TextFrame.Characters.Font.Name = "Tahoma"
.Comment.Shape.TextFrame.Characters.Font.Size = 9
End With
End Sub
|