Summe nach Monaten
21.10.2008 19:56:12
Becker
Hallo Ihr lieben,
Ich möchte in "KalendarSummeNachMonat" noch paar Kleinigkeiten dazu bauen.
Hat jemand eine Ahnung wie ich das anstellen könnte?
Unten in Code kommentiere ich meine Fragen aus;
Sub KalendarSummeNachMonat()
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
Ich hoffe Ihr könnt mir weiterhelfen...
Für jede Hilfe bin ich sehr dankbar.
MfG Daniel