Calendario su più fogli
Di seguito il codice per generare un file contenente 12 fogli (uno per mese) con settati
- weekend;
- festività nazionali (italiane);
- santo patrono;
- Pasqua;
A vostro piacimento potete inserire ulteriori festività. In esecuzione viene chiesto l'anno di cui deve generare il calendario, ovviamente il patrono sarà compito vostro inserirlo corretto
Option Base 1 Dim nYear As Integer Sub lfValur() Dim holyD() As Boolean nYear = CInt(InputBox("Anno:", "Select year")) For i = 1 To 12 Sheets.Add After:=Sheets(Sheets.Count) ActiveSheet.Name = StrConv(MonthName(i, False), vbProperCase) lfDayFiller (i) Next End Sub Function lfDayFiller(lfMese As Integer) Dim i, z As Byte Dim dElab, dEaster As Date Dim nameM As String 'dayM numero di giorni nel mese valutato dayM = DaysInMonth(DateSerial(nYear, lfMese, 1)) ReDim holyD(dayM) dElab = DateSerial(nYear, lfMese, 1) For i = 1 To dayM 'setto i weekend If Weekday(dElab, 2) = 6 Or Weekday(dElab, 2) = 7 Then holyD(i) = True Else holyD(i) = False End If dElab = dElab + 1 Next 'controllo pasqua dEaster = Pasqua(nYear) If Month(dEaster) = lfMese Then holyD(Day(dEaster)) = True holyD(Day(dEaster) + 1) = True 'lunedì dell'angelo End If Select Case lfMese Case 1 '1 gennaio Capodanno '6 gennaio Epifania holyD(1) = True holyD(6) = True Case 2 Case 3 Case 4 '25 aprile Liberazione dal ... holyD(25) = True Case 5 '1 maggio Festa del lavoro holyD(1) = True Case 6 '2 giugno Festa della Repubblica holyD(2) = True Case 7 Case 8 '15 agosto Assunzione holyD(15) = True Case 9 Case 10 Case 11 '1 novembre Ognissanti '3 novembre S.Giusto holyD(1) = True holyD(3) = True Case 12 '8 dicembre Immacolata '25 dicembre Natale '26 dicembre Santo Stefano holyD(8) = True holyD(25) = True holyD(26) = True End Select 'Inserisco i gg For i = 1 To dayM If holyD(i) = True Then Range(Cells(i , 1), Cells(i, 1)).Select With Selection.Interior .Pattern = xlLightUp .PatternColorIndex = xlAutomatic .ThemeColor = xlThemeColorDark1 .TintAndShade = -4.99893185216834E-02 .PatternTintAndShade = 0 End With End If Cells(i , 1).Value = DateSerial(nYear, lfMese, i) Next Range("A1:A31").Select Selection.NumberFormat = "m/d/yyyy" Columns("A:A").Select Columns("A:A").EntireColumn.AutoFit 'Cells(1, 1).Select End Function Function DaysInMonth(MyDate As Date) As Long Dim NextMonth As Date Dim EndOfMonth As Date NextMonth = DateAdd("m", 1, MyDate) EndOfMonth = NextMonth - DatePart("d", NextMonth) DaysInMonth = DatePart("d", EndOfMonth) End Function Public Function Pasqua(ByVal anno As Integer) As Date Dim a%, b%, c%, p%, q%, r% a = anno% Mod 19: b = anno% \ 100: c = anno% Mod 100 p = (19 * a + b - (b \ 4) - ((b - ((b + 8) \ 25) + 1) \ 3) + 15) Mod 30 q = (32 + 2 * ((b Mod 4) + (c \ 4)) - p - (c Mod 4)) Mod 7 r = (p + q - 7 * ((a + 11 * p + 22 * q) \ 451) + 114) Pasqua = DateSerial(anno%, r \ 31, (r Mod 31) + 1) End Function 'http://it.wikipedia.org/wiki/Calcolo_della_Pasqua