Sub Kalend-SummeNachMonat()
 
Dim sGod$
Dim i%, n%, r%, s%
Dim cCel As range
 
Application.ScreenUpdating = False
 
sGod = InputBox("Kalendar za:", , Year(Date))
If sGod = "" Then Exit Sub
range("L1") = "Datum"
range("N1") = "Woche"
range("O1") = "Daly-Sum"
With range("L1:O1")
With .Font
.Bold = True
.Size = 10
.ColorIndex = 36
End With
.Interior.ColorIndex = 12
End With
If sGod Mod 4 = 0 Then n = 367 Else n = 366
range("L2,M2") = DateSerial(sGod, 1, 1)
range("L3").Formula = "=L2+1"
range("M3").Formula = "=L2+1"
range("N2:N3").Formula = "=Woche(L2)"
range("L3:N" & n).FillDown
range("L2:N" & n).Copy
range("L2:N" & n).PasteSpecial (xlValues)
range("M2:M" & n).NumberFormat = "dddd"
range("M1") = "Dan"
range("M1").HorizontalAlignment = xlRight
'WE ferbän
r = 2
Do Until IsEmpty(Cells(r, 12))
If Weekday(Cells(r, 12)) = 7 Then
range(Cells(r, 12), Cells(r, 14)).Interior.ColorIndex = 37
ElseIf Weekday(Cells(r, 12)) = 1 Then
range(Cells(r, 12), Cells(r, 14)).Interior.ColorIndex = 22
End If
r = r + 1
Loop
 
Columns("L:N").EntireColumn.AutoFit
Columns("M:N").Select
Selection.Delete Shift:=xlToLeft
range("M2").Select
range("M2:M3").Formula = "=SUMIF(C[-9],RC[-1],C[-7])"
range("M3:M" & n).FillDown
 
'Frage a)
'wie kann man ab hier den Befehl einbauen; im Spaltenbereich 
'L:M (in vertikalen Kalender Bereich)
'zwei leere Spalten am Ende des jeweiligen Monat einfügen? 
' Als Beispiel; range("L32:M33").Select
'Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
'dann solle in L32 "Gesamm"(range("L32") = "Gesamt") stehen
'und in M32 Formel Summe(M2:M31)
 
'Frage b)
'Ist es möglich danach dass in erste freie Spalte z.B. 
'N1:N12 die Monaten von Jänner-Dezember ausgeschrieben
'werden und von O1:O12 dessen Monats Summen aus Spalte M???
 
 
 
End Sub
 
Public Function Uskrs(Gd As Integer)
 Dim D As Integer
 D = (((255 - 11 * (Gd Mod 19)) - 21) Mod 30) + 21
 Uskrs = DateSerial(Gd, 3, 1) + D + (D > 48) + _
 6 - ((Gd + Gd \ 4 + D + (D > 48) + 1) Mod 7)
 End Function
 
Function Sedmica(Datum As Date) As Integer
Dim t&
t = DateSerial(Year(Datum + (8 - Weekday(Datum)) Mod 7 - 3), 1, 1)
Sedmica = (Datum - t - 3 + (Weekday(t) + 1) Mod 7) \ 7 + 1
End Function
 
Public Function Uskrs(Gd As Integer)
 Dim D As Integer
 D = (((255 - 11 * (Gd Mod 19)) - 21) Mod 30) + 21
 Uskrs = DateSerial(Gd, 3, 1) + D + (D > 48) + _
 6 - ((Gd + Gd \ 4 + D + (D > 48) + 1) Mod 7)
 End Function
 
Function Sedmica(Datum As Date) As Integer
Dim t&
t = DateSerial(Year(Datum + (8 - Weekday(Datum)) Mod 7 - 3), 1, 1)
Sedmica = (Datum - t - 3 + (Weekday(t) + 1) Mod 7) \ 7 + 1
End Function