[Office 2007] makro code für jahreskalender in einer zeile einfügen.


Forum: Office 2007 Forum

Probleme mit Programmen der Office 2007 Reihe werden hier diskutiert. (Excel 2007, Word 2007, Access 2007, Outlook 2007 etc.)

  1. congerx

    congerx Guest

    Wer Kann mir helfen
    was gemacht werden soll

    - Feiertage in den Kalender automatisieren.
    - Projektstart und Ende im Kalender markieren,
    - Im Dropdownmenü leere Zellen nicht anzeigen.
    Möchte ein Makro Code für Jahreskalender in einer Zeile einfügen.

    Etwa sowas


    Option Explicit

    Public Sub Erstellen()
    Call Kalender_erstellen(ActiveSheet.Range("B5"), "01.01.09", "30.06.09", True, True, True, 5, 15, 45, 4, 3, False, False, 18, 15)
    Call Kalender_erstellen(ActiveSheet.Range("B16"), "01.07.09", "31.12.09", True, True, True, 5, 15, 45, 4, 3, False, False, 18, 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[​IMG].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 = xlDouble
    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


     
  2. Werbung
Die Seite wird geladen...
Hier genannte Produkt- und Firmennamen sowie deren Logos koennen eingetragene Warenzeichen der jeweiligen Unternehmen sein.