VBATools

Tworzenie kalendarza w arkuszu

by on Jan.24, 2012, under Excel, Porady

W niektórych przypadkach chcemy oznaczyć wydarzenia w arkuszu, bazując na aktualnym kalendarzu. Nie chcemy tworzyć go na podstawie formuł, które obciążają obliczenia, ale przedstawić jako tabelę.

Poniższy sposób przedstawia jak taki kalendarz wykonać kodem VBA:

Rys: Wygląd utworzonego kalendarza w arkuszu.

 Option Explicit 

 Dim jakie_sw$ 

 Sub tworz_kalendarz_w_arkuszu() 
 'VBATools.pl MVP Oskar Shon 
 Dim i%, x&, kon_msca&, miesiac$, dzientyg$, nrtyg&, Rok& 
 On Error GoTo blad_rok 
 ponownie: 
 With Application 
 Rok = .InputBox("Podaj rok, dla którego będzie utworzony kalendarz:", _ 
 "Rysownie kalendarza w arkuszu:", Year(Now), Type:=2) 'określenie typu danych 
 On Error GoTo blad 
 If Rok = 0 Then GoTo koniec 
 .ScreenUpdating = False 
 .EnableEvents = False 
 .Calculation = xlCalculationManual 
 .StatusBar = "Tworzenie kalendarza..." 
 For i = 1 To 12 
 kon_msca = Day(DateSerial(Rok, i + 1, 1) - 1) 
 miesiac = Format(DateSerial(Rok, i, 1), "mmmm") 
 For x = 1 To 31 
 nrtyg = Weekday(DateSerial(Rok, i, x), vbUseSystemDayOfWeek) 
 dzientyg = WeekdayName(nrtyg) 
 Cells(i, x).Value = x & " " & miesiac & " " & Rok & vbNewLine & dzientyg 
 If nrtyg > 5 Then Cells(i, x).Interior.ColorIndex = 15 
 If czy_swieta(DateSerial(Rok, i, x)) = True Then 
 Cells(i, x).Interior.ColorIndex = 8 
 Cells(i, x).Value = Cells(i, x).Value & vbNewLine & jakie_sw 
 End If 
 If x = kon_msca Then Exit For 
 Next x 
 Next i 
 koniec: 
 .StatusBar = False 
 .EnableEvents = True 
 .Calculation = xlCalculationAutomatic 
 .ScreenUpdating = True 
 End With 
 Beep 
 Exit Sub 
 blad_rok: 
 Resume ponownie 
 Exit Sub 
 blad: 
 MsgBox "Błąd:" & Err.Number & vbCr & Err.Description 
 Resume koniec 
 End Sub 

 Private Function czy_swieta(ByVal dData As Date) As Boolean 
 'mod by MVP Oskar Shon 
 Dim iRok As Integer: iRok = Year(dData) 
 If dData = DateSerial(iRok, 1, 1) Then czy_swieta = True: jakie_sw = "Nowy Rok" 
 If dData = Wielkanoc(iRok) Then czy_swieta = True: jakie_sw = "Wielkanoc" 
 If dData = Wielkanoc(iRok) + 1 Then czy_swieta = True: jakie_sw = "Wielkanoc" 
 If dData = DateSerial(iRok, 5, 1) Then czy_swieta = True: jakie_sw = "Święto Pracy" 
 If dData = DateSerial(iRok, 5, 3) Then czy_swieta = True: jakie_sw = "3 Maja" 
 If dData = Wielkanoc(iRok) + 49 Then czy_swieta = True: jakie_sw = "Zielone Świątki" 
 If dData = Wielkanoc(iRok) + 49 + 11 Then czy_swieta = True: jakie_sw = "Boże ciało" 
 If dData = DateSerial(iRok, 8, 15) Then czy_swieta = True: jakie_sw = "Wniebowzięcie NMP" 
 If dData = DateSerial(iRok, 11, 1) Then czy_swieta = True: jakie_sw = "Wszystkich Świętych" 
 If dData = DateSerial(iRok, 11, 11) Then czy_swieta = True: jakie_sw = "Święto Niepodległości" 
 If dData = DateSerial(iRok, 12, 25) Then czy_swieta = True: jakie_sw = "Boże Narodzenie" 
 If dData = DateSerial(iRok, 12, 26) Then czy_swieta = True: jakie_sw = "Boże Narodzenie" 
 'If Weekday(dData, 2) > 5 Then czy_swieta = True 
 End Function 

 Private Function Wielkanoc(ByVal Rok As Integer) As Date 
 'http://www.cpearson.com/excel/holidays.htm poprawna dla lat 1900 - 2099 
 Dim id As Integer 
 id = (((255 - 11 * (Rok Mod 19)) - 21) Mod 30) + 21 
 Wielkanoc = DateSerial(Rok, 3, 1) + id + (id > 48) + 6 - ((Rok + Rok \ 4 + _ 
 id + (id > 48) + 1) Mod 7) 
 End Function 

(c) Shon Oskar – www.VBATools.pl

Wszelkie prawa zastrzeżone. Żadna część ani całość tego artykułu nie może być powielana ani publikowana bez zgody autora.
:, ,

Leave a Reply

Ostatnio zalogowani:

Profile picture of vbatools
Profile picture of marcinmachalowski
Profile picture of Anorak
Profile picture of Joanna Subik
Profile picture of Karol Stilger
Profile picture of programistaaccess
Profile picture of piotrpawlik
Profile picture of Emil Wasilewski
Profile picture of kicekpicek
Profile picture of coldfusion
Profile picture of Gosia Borzęcka
Profile picture of lukaszch
Profile picture of itadministracja
Profile picture of farbenia
Profile picture of Łukasz Kałużny
Profile picture of kabzinski
Profile picture of rtynski
Profile picture of leszekbetlinski
Profile picture of Iv
Profile picture of Justyna Spychała