Prikazi cijelu temu 02.06.2012 19:35
zxz Van mreze
Administrator
Registrovan od:03.02.2009
Lokacija:Tuzla


Predmet:Kalendar u exelu
Ovu proceduru kopirajte u neki modul.

PreuzmiIzvorni kôd (Visual Basic):
  1. Function Kalendar()
  2. Dim WKS As Worksheet
  3. Dim StrMjesec As String
  4. Dim Mjesec As Integer
  5. Dim Adresa(1 To 2) As String
  6. Dim Polje As Range
  7. Dim Red(1 To 2) As Integer
  8. Dim Kolona(1 To 2) As Integer
  9. Dim K(1 To 2) As Integer
  10. Dim Celija As Range
  11. Dim Dan As Integer
  12. Dim Datum As Date
  13. Dim Ime As String
  14.  
  15. Set WKS = Worksheets.Add
  16. Ime = "Kalendar" & Mid(WKS.Name, 6)
  17. WKS.Name = Ime
  18. ActiveWindow.DisplayGridlines = False
  19. With Cells
  20. .ColumnWidth = 6#
  21. .Font.Size = 8
  22. End With
  23. K(2) = 1
  24.  
  25. For Mjesec = 1 To 12
  26. StrMjesec = Choose(Mjesec, "Januar", "Februar", "Mart", "April", "Maj", "Juni", "Juli", _
  27.               "August", "Septembar", "Oktobar", "Novembar", "Decembar")
  28.  
  29. K(1) = Mjesec Mod 3
  30. If K(1) = 0 Then K(1) = 3
  31. Kolona(2) = K(1) * 7
  32. Kolona(1) = Kolona(2) - 6
  33. Red(2) = K(2) * 8
  34. Red(1) = Red(2) - 7
  35. Set Polje = WKS.Cells(Red(1), Kolona(1))
  36. Adresa(1) = Polje.Address
  37. Set Polje = WKS.Cells(Red(1), Kolona(2))
  38. Adresa(2) = Polje.Address
  39. Set Polje = Range(Adresa(1), Adresa(2))
  40. Polje.Merge
  41. Polje.Value = StrMjesec
  42. Polje.HorizontalAlignment = xlCenter
  43. Polje.Interior.ColorIndex = 6
  44. Polje.Font.Bold = True
  45. Pol****rderAround LineStyle:=xlContinuous
  46. Red(1) = Red(1) + 1
  47. Set Polje = WKS.Cells(Red(1), Kolona(1))
  48. Adresa(1) = Polje.Address
  49. Set Polje = WKS.Cells(Red(1), Kolona(2))
  50. Adresa(2) = Polje.Address
  51. Range(Adresa(1), Adresa(2)).BorderAround LineStyle:=xlContinuous
  52. Range(Adresa(1), Adresa(2)).Interior.ColorIndex = 1
  53. Range(Adresa(1), Adresa(2)).Font.ColorIndex = 2
  54. Dan = 0
  55.   For Each Celija In Range(Adresa(1), Adresa(2))
  56.   Dan = Dan + 1
  57.   Datum = DateSerial(Year(Date), Mjesec, Dan)
  58.   With Celija
  59.   .Value = Datum
  60.   .NumberFormat = "ddd"
  61.   End With
  62.   Next Celija
  63. Red(1) = Red(1) + 1
  64. Set Polje = WKS.Cells(Red(1), Kolona(1))
  65. Adresa(1) = Polje.Address
  66. Set Polje = WKS.Cells(Red(2), Kolona(2))
  67. Adresa(2) = Polje.Address
  68. Dan = 0
  69.  Range(Adresa(1), Adresa(2)).BorderAround LineStyle:=xlContinuous
  70.  Range(Adresa(1), Adresa(2)).Interior.ColorIndex = 15
  71.     For Each Celija In Range(Adresa(1), Adresa(2))
  72.     Dan = Dan + 1
  73.     Datum = DateSerial(Year(Date), Mjesec, Dan)
  74.        If Month(Datum) = Mjesec Then
  75.               With Celija
  76.               .Value = Datum
  77.               .NumberFormat = "dd"
  78.               If Datum = Date Then
  79.               Celija.BorderAround LineStyle:=xlContinuous
  80.               'Celija.Interior.ColorIndex = 9
  81.              Celija.Select
  82.               End If
  83.               End With
  84.        End If
  85.     Next Celija
  86. If K(1) = 3 Then
  87. K(2) = K(2) + 1
  88. End If
  89. Next Mjesec
  90.    
  91. End Function
Podrška samo putem foruma, jer samo tako i ostali imaju koristi od toga.
Ovaj post je ureden 1 puta. Posljednja izmjena 02.06.2012 19:52 od strane zxz.