Anwendungs-Software und Apps 14.435 Themen, 72.967 Beiträge

Kostenlose Kalender

schoppes / 2 Antworten / Flachansicht Nickles
"Früher war alles besser. Sogar die Zukunft." (Karl Valentin)
bei Antwort benachrichtigen
gelöscht_265507 schoppes „Kostenlose Kalender“
Optionen

Option Explicit
Sub KalenderEinfügen() 'Jahreskalenderblatt

Dim Z, S, Year, Month, Day
Dim Eingabe As String
Dim erg%

Eingabe = InputBox("Bitte gib die Jahreszahl ein:", "Jahreskalender")
If IsNumeric(Eingabe) And Eingabe > "2000" And Eingabe Year = Eingabe
Else
erg = MsgBox("Jahreszahl ist ungültig.", vbCritical, "Nur Zahlen eingeben")
End
End If

Cells(1, 1) = Year
Z = 1
S = 1

'Formatierungen und Ausgangswerte
Range(Cells(Z, S + 1), Cells(Z, S + 12)).NumberFormat = "MMM"
Range(Cells(Z, S + 1), Cells(Z, S + 12)).HorizontalAlignment = xlCenter
Range(Cells(Z + 1, S), Cells(Z + 31, S)).NumberFormat = "0""."""
Range(Cells(Z + 1, S), Cells(Z + 31, S + 12)).HorizontalAlignment = xlLeft
Range(Cells(Z + 1, S + 1), Cells(Z + 31, S + 12)).NumberFormat = "DDD"
Range(Cells(Z, S), Cells(Z + 31, S + 12)).Borders.ColorIndex = 1
Range(Cells(Z, S), Cells(Z + 31, S + 12)).Interior.ColorIndex = 0
Range(Cells(Z + 1, S), Cells(Z + 31, S + 12)).Formula = ""

'Felder ausfüllen
For Month = 1 To 12
Cells(Z, S + Month) = CDate(1 & "." & Month & "." & Year)
For Day = 1 To 31
Cells(Z + Day, S) = Day
If IsDate(Day & "." & Month & "." & Year) Then
Cells(Z + Day, S + Month) = CDate(Day & "." & Month & "." & Year)
If Weekday(Cells(Z + Day, S + Month)) = 1 Then
Cells(Z + Day, S + Month).Interior.ColorIndex = 48
ElseIf Weekday(Cells(Z + Day, S + Month)) = 7 Then
Cells(Z + Day, S + Month).Interior.ColorIndex = 15
End If
End If
Next
Next
End Sub

bei Antwort benachrichtigen