VBATools

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