VBA-Beispiel 052
mail schreiben
mail schreiben

erstellt für den aktuellen Monat einen Kalender
Der Kalender eignet sich z.B. gut als Anwesenheitsliste. Wochenendtage werden farblich markiert.
Sub Monat_anlegen()
'legt für den aktuellen Monat einen Kalender an
Dim Jahr As String, neuerMonat As String  
Dim Monat As Integer, Tag As Integer, AnzTage As Integer    
Dim d As Date
Dim wks As Worksheet

On Error GoTo Fehler    

Jahr = Year(Date)
Monat = Month(Date)

'Anzahl Tage des aktuellen Monats
AnzTage = DateSerial(Year(Now), Month(Now) + 1, 1) _
        - DateSerial(Year(Now), Month(Now), 1)

neuerMonat = Format(Date, "mmm. yy")

'prüfen ob Tabelle schon vorhanden ist
For Each wks In ThisWorkbook.Worksheets  
    If wks.name = neuerMonat Then  
        MsgBox ("Tabelle ist für diesen Monat schon vorhanden" _
                & vbNewLine & vbNewLine & wks.name)
        Worksheets(wks.name).Visible = True
        Worksheets(wks.name).Activate
        Exit Sub  
    End If  
Next wks

'neue Monatstabelle anlegen
   Worksheets.Add After:=Worksheets(Worksheets.Count)
   ActiveSheet.name = neuerMonat

   Range("A1:AH2").Interior.ColorIndex = 35  
   Range("D1:AH1").NumberFormat = "d"  
   Range("D1:AH2").HorizontalAlignment = xlCenter
   Range("D2:AH2").NumberFormat = "ddd"  

   For Tag = 1 To AnzTage  
     With Cells(1, Tag + 3)
       d = DateSerial(Jahr, Monat, Tag)
           .Value = d
               'prüfen ob Sa / So wenn ja Hintergrundfarbe grün
                If Weekday(d) = 1 Or Weekday(d) = 7 Then  
                    Range(Cells(3, Tag + 3), (Cells(40, Tag + 3))).Interior.ColorIndex = 35  
                End If  
            Cells(2, Tag + 3) = d
       End With  
   Next Tag

Columns("D:AH").ColumnWidth = 3
Cells(3, 1).Activate
Cells(1, 1) = "Name"
Cells(1, 2) = "Vorname"
Cells(1, 3) = "geb"

Exit Sub  

Fehler:

    MsgBox "FehlerNr.: " & Err.Number & vbNewLine & vbNewLine _
    & "Beschreibung: " & Err.Description _
    , vbCritical, "Fehler"
End Sub
Download:   vba052.zip
relevante Links:

top