Sub
Kalendar()
Dim sGod$
Dim i%, n%, r%, s%
Dim cCel As Range
Dim TB1 As
Worksheet
Dim TB2 As
Worksheet
Application.ScreenUpdating = False
sGod = InputBox("Kalendar za:", , Year(Date))
If sGod = "" Then Exit Sub
Worksheets("praznici").Range("C1") = CInt(sGod)
Worksheets.Add.Name = CInt(sGod)
Range("A1") = "Datum"
Range("C1") = "Sedmica"
With Range("A1:C1")
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("A2,b2") = DateSerial(sGod, 1, 1)
Range("A3").Formula = "=A2+1"
Range("b3").Formula = "=A2+1"
Range("c2:c3").Formula = "=Sedmica(A2)"
Range("A3:c" & n).FillDown
Range("A2:c" & n).Copy
Range("A2:c" & n).PasteSpecial (xlValues)
Range("B2:B" & n).NumberFormat = "dddd"
Range("B1") = "Dan"
Range("B1").HorizontalAlignment = xlRight
'Bojanje subote i nedjelje
r = 2
Do Until IsEmpty(Cells(r, 1))
If Weekday(Cells(r, 1)) = 7
Then
Range(Cells(r, 1), Cells(r, 3)).Interior.ColorIndex = 37
ElseIf Weekday(Cells(r, 1)) = 1
Then
Range(Cells(r, 1), Cells(r, 3)).Interior.ColorIndex = 22
End If
r = r + 1
Loop
'dodavanje praznika
Set TB2 = Worksheets(sGod)
Set TB1 = Worksheets("PRAZNICI")
s = 1
Do Until IsEmpty(TB1.Cells(s, 2))
Set cCel = Range("A:A").Find(DateValue(TB1.Cells(s, 1)), LookIn:=xlFormulas)
With cCel
.Interior.ColorIndex = 4
.Offset(0, 1).Interior.ColorIndex = 4
.NoteText TB1.Cells(s, 2)
End With
s = s + 1
Loop
Columns("A:C").EntireColumn.AutoFit
Range("A1").Select
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
