Hallo Marta,
ein Datum vor März 1900 ist in Excel falsch. Die gehen einen Tag vor. Weil Excel einen 29.02.1900 kennt den es aber nicht gab da 1900 kein Schaltjahr war.
Ich habe mal etwas an deinem Code geschraubt.
Den auskommentierten Teil brauchst du nicht. Der macht keinen Sinn.
Sub Kalender_Klicken()
ActiveSheet.Protect DrawingObjects:=False, Contents:=False, _
Scenarios:=False
On Error GoTo MyErrorTrap
Range("C3:I3").ClearContents
Range("C4:I10").ClearContents
MyInput = InputBox("aktueller Monat", "Monat", Format(Date, "mmmm yyyy"), 5000, 5000)
If StrPtr(MyInput) = 0 Or MyInput = "" Or Trim(MyInput) = "" Then Exit Sub
Application.ScreenUpdating = False
StartDay = DateValue(MyInput)
If Day(StartDay) <> 1 Then
StartDay = DateValue(Month(StartDay) & "/1/" & _
Year(StartDay))
End If
Call ConvertToZahl
With Range("C3:I3")
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlCenter
.Font.Size = 22
.Font.Bold = True
.RowHeight = 30
End With
With Range("C4:I4")
.ColumnWidth = 2
.VerticalAlignment = xlCenter
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Orientation = xlHorizontal
.Font.Size = 7
.Font.Bold = False
.RowHeight = 14
End With
Range("C4") = "MO"
Range("D4") = "DI"
Range("E4") = "MI"
Range("F4") = "DO"
Range("G4") = "FR"
Range("H4") = "SA"
Range("I4") = "SO"
With Range("C4:I10")
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Font.Size = 7
.Font.Bold = False
.RowHeight = 14
End With
Range("C3").Value = Application.Text(MyInput, "MMMM yyyy")
DayofWeek = Weekday(StartDay, vbMonday)
CurYear = Year(StartDay)
CurMonth = Month(StartDay)
FinalDay = DateSerial(CurYear, CurMonth + 1, 1)
Select Case DayofWeek
Case 1
Range("C5").Value = StartDay
Case 2
Range("D5").Value = StartDay
Case 3
Range("E5").Value = StartDay
Case 4
Range("F5").Value = StartDay
Case 5
Range("G5").Value = StartDay
Case 6
Range("H5").Value = StartDay
Case 7
Range("I5").Value = StartDay
End Select
For Each cell In Range("C5:I10")
RowCell = cell.Row
ColCell = cell.Column
If ColCell <> 3 Then
If cell.Offset(0, -1).Value >= 1 Then
cell.Value = cell.Offset(0, -1).Value + 1
If cell.Value = FinalDay Then
cell.Value = ""
Exit For
End If
End If
ElseIf RowCell > 5 And ColCell = 3 Then
cell.Value = cell.Offset(-1, 6).Value + 1
If cell.Value = FinalDay Then
cell.Value = ""
Exit For
End If
End If
Next
' For DayofWeek = StartDay To FinalDay
'
'
' If Weekday(StartDay, vbMonday) = 1 Then
'
' Call mach(Range("B4").Value, Range("C5"), "2,vbMonday")
' Call mach(Range("B4").Value, Range("D5"), "3,vbTuesday")
' Call mach(Range("B4").Value, Range("E5"), "4,vbWednesday")
' Call mach(Range("B4").Value, Range("F5"), "5,vbThursday")
' Call mach(Range("B4").Value, Range("G5"), "6,vbFriday")
' Call mach(Range("B4").Value, Range("H5"), "7,vbSaturday")
' Call mach(Range("B4").Value, Range("I5"), "1,vbSunday")
'
' ElseIf Weekday(vbMonday - vbTuesday - vbWednesday - vbThursday - vbFriday - vbSaturday - vbSunday) = 2 Then ' Di
'
' Call mach(Range("B4").Value, Range("D5"), "3")
' Call mach(Range("B4").Value, Range("E5"), "4")
' Call mach(Range("B4").Value, Range("F5"), "5")
' Call mach(Range("B4").Value, Range("G5"), "6")
' Call mach(Range("B4").Value, Range("H5"), "7")
' Call mach(Range("B4").Value, Range("I5"), "1")
' Call mach(Range("B4").Value, Range("C6"), "2")
'
' ElseIf Weekday(vbMonday - vbTuesday - vbWednesday - vbThursday - vbFriday - vbSaturday - vbSunday) = 3 Then ' MI
'
' Call mach(Range("B4").Value, Range("E5"), "4")
' Call mach(Range("B4").Value, Range("F5"), "5")
' Call mach(Range("B4").Value, Range("G5"), "6")
' Call mach(Range("B4").Value, Range("H5"), "7")
' Call mach(Range("B4").Value, Range("I5"), "1")
' Call mach(Range("B4").Value, Range("C6"), "2")
' Call mach(Range("B4").Value, Range("D6"), "3")
'
' ElseIf Weekday(vbMonday - vbTuesday - vbWednesday - vbThursday - vbFriday - vbSaturday - vbSunday) = 4 Then ' Do
'
' Call mach(Range("B4").Value, Range("F5"), "5")
' Call mach(Range("B4").Value, Range("G5"), "6")
' Call mach(Range("B4").Value, Range("H5"), "7")
' Call mach(Range("B4").Value, Range("I5"), "1")
' Call mach(Range("B4").Value, Range("C6"), "2")
' Call mach(Range("B4").Value, Range("D6"), "3")
' Call mach(Range("B4").Value, Range("E6"), "4")
'
' ElseIf Weekday(vbMonday - vbTuesday - vbWednesday - vbThursday - vbFriday - vbSaturday - vbSunday) = 5 Then ' Fr
'
' Call mach(Range("B4").Value, Range("G5"), "6")
' Call mach(Range("B4").Value, Range("H5"), "7")
' Call mach(Range("B4").Value, Range("I5"), "1")
' Call mach(Range("B4").Value, Range("C6"), "2")
' Call mach(Range("B4").Value, Range("D6"), "3")
' Call mach(Range("B4").Value, Range("E6"), "4")
' Call mach(Range("B4").Value, Range("F6"), "5")
'
' ElseIf Weekday(vbMonday - vbTuesday - vbWednesday - vbThursday - vbFriday - vbSaturday - vbSunday) = 6 Then ' Sa
'
' Call mach(Range("B4").Value, Range("H5"), "7")
' Call mach(Range("B4").Value, Range("I5"), "1")
' Call mach(Range("B4").Value, Range("C6"), "2")
' Call mach(Range("B4").Value, Range("D6"), "3")
' Call mach(Range("B4").Value, Range("E6"), "4")
' Call mach(Range("B4").Value, Range("F6"), "5")
' Call mach(Range("B4").Value, Range("G6"), "6")
'
' ElseIf Weekday(vbMonday - vbTuesday - vbWednesday - vbThursday - vbFriday - vbSaturday - vbSunday) = 7 Then ' Sonntag
'
' Call mach(Range("B4").Value, Range("I5"), "1")
' Call mach(Range("B4").Value, Range("C6"), "2")
' Call mach(Range("B4").Value, Range("D6"), "3")
' Call mach(Range("B4").Value, Range("E6"), "4")
' Call mach(Range("B4").Value, Range("F6"), "5")
' Call mach(Range("B4").Value, Range("G6"), "6")
' Call mach(Range("B4").Value, Range("H6"), "7")
'
' End If
'
' Next DayofWeek
Application.ScreenUpdating = True
Exit Sub
MyErrorTrap:
MsgBox "Monat oder Jahr ist nicht Korrekt." _
& Chr(13) & "Bitte den Monat richtig eingeben" _
& " (oder versuchen Sie später)" _
& Chr(13) & "Jahr vieleicht"
MyInput = InputBox("Monat + Jahr")
If MyInput = "" Then Exit Sub
Resume
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
End Sub
Gruß
Nepumuk