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:

XL_Kalendarz_w_arkuszu

Rys: Wygląd utworzonego kalendarza w arkuszu.

Sub tworz_kalendarz_w_arkuszu()
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 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

(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

Recently Active Members

Profile picture of vbatools
Profile picture of Karol Stilger
Profile picture of Joanna Subik
Profile picture of Anorak
Profile picture of marcinmachalowski
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