Επίσημες Αργίες για κάθε έτος

Μια και είναι Αύγουστος, μήνας των διακοπών, να μια ρουτίνα με την οποία θα μπορείτε να προγραμματίζετε τις διακοπές και τις άδειές σας.  «Βίος ανεόρταστος, μακρά οδός απανδόχευτος» μας άφησε παρακαταθήκη ο Aβδηρίτης Δημόκριτος !
Η μακροεντολή που ακολουθεί  προσθέτει στο βιβλίο σας ένα φύλλο με τις επίσημες αργίες που ισχύουν σήμερα στην Ελλάδα, για το έτος που θα επιλέξετε. Το φύλλο θα έχει την μορφή που βλέπετε στην εικόνα.
Την μακροεντολή θα βρείτε και στο excel βιβλίο:GreekHolidays

Sub GreekHolidays()
Dim text1, text2, text3 As String
Dim oSheetName As String
Dim h, j As Integer
Dim oed As Date
Dim myRange As Range
Dim e As Variant
Dim Vd As Variant
Dim Vt As Variant
text1 = "Πληκτρολογείστε ένα τετραψήφιο έτος (1950-2099)"
text2 = "Επίσημες αργίες"
text3 = "Έτος εκτός ορίων"
encore:
e = Application.InputBox(text1, text2, Year(Now), , , , , 1)
If e = False Then GoTo myEnd
If e < 1950 Or e > 2099 Then MsgBox text3: GoTo encore
h = ((19 * (e Mod 19) + 16) Mod 30) + _
    ((2 * (e Mod 4) + 4 * (e Mod 7) + _
    6 * ((19 * (e Mod 19) + 16) Mod 30)) Mod 7) + 3
oed = DateSerial(e, 3, 31) + h
Vd = VBA.Array(DateSerial(e, 1, 1), DateSerial(e, 1, 6), _
                DateSerial(e, 3, 25), DateSerial(e, 5, 1), _
                DateSerial(e, 8, 15), DateSerial(e, 10, 28), _
                DateSerial(e, 12, 25), DateSerial(e, 12, 26), _
                oed - 48, oed - 2, oed, oed + 1, oed + 50)
Vt = VBA.Array("Πρωτοχρονιά", "Θεοφάνεια", "Εθνική Εορτή", "Πρωτομαγιά", _
"Κοίμηση Θεοτόκου", "Εθνική Εορτή", "Χριστούγεννα", "Σύναξη Θεοτόκου", _
"Καθαρά Δευτέρα", "Μεγάλη Παρασκευή", "Άγιο Πάσχα", "Δευτέρα Διακαινησίμου", _
"Αγίου Πνεύματος(*)")
oSheetName = "Εορτολόγιο" & e
If CheckSheetExist(oSheetName) = True Then Sheets(oSheetName).Select: GoTo myEnd
Sheets.Add.Name = oSheetName
Set myRange = Range("a2:b14")
myRange.item(0, 1) = "Επίσημες αργίες για το έτος " & e
For j = 1 To 13
    myRange.item(j, 1) = Vd(j - 1)
    myRange.item(j, 2) = Vt(j - 1)
    myRange.item(j, 1).NumberFormat = "dddd, d-mmm-yy"
Next
myRange.EntireColumn.AutoFit
myRange.Sort Key1:=myRange.item(1, 1)
myEnd:
End Sub
Private Function CheckSheetExist(ByVal SheetName As String) As Boolean
On Error Resume Next
CheckSheetExist = (Sheets(SheetName).Name <> "")
On Error GoTo 0
End Function
This entry was posted in excel, Μακροεντολές, VBA and tagged , , , , , . Bookmark the permalink.