Option Explicit
Sub Monat_anlegen()
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)
AnzTage = DateSerial(Year(Now), Month(Now) + 1, 1) _
- DateSerial(Year(Now), Month(Now), 1)
neuerMonat = Format(Date, "mmm. yy")
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
Worksheets.Add After:=Worksheets(Worksheets.Count)
ActiveSheet.name = neuerMonat
Range("D1: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
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
Exit Sub
Fehler:
MsgBox "FehlerNr.: " & Err.Number & vbNewLine & vbNewLine _
& "Beschreibung: " & Err.Description _
, vbCritical, "Fehler"
End Sub