Sub MyHolidays()
Dim rw1, rw2, col, LastRow As Long
Dim myDay
Dim MonthNum As Integer
Dim myMonth As String
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
LastRow = Range("J" & Rows.Count).End(xlUp).Row
For rw1 = 7 To LastRow
MonthNum = Month(Cells(rw1, "J")) 'Gives the number of the month, ie. 1, 2 to 12
If MonthNum = 1 Then myMonth = "JANUARY"
If MonthNum = 2 Then myMonth = "FEBRUARY"
If MonthNum = 3 Then myMonth = "MARCH"
If MonthNum = 4 Then myMonth = "APRIL"
If MonthNum = 5 Then myMonth = "MAY"
If MonthNum = 6 Then myMonth = "JUNE"
If MonthNum = 7 Then myMonth = "JULY"
If MonthNum = 8 Then myMonth = "AUGUST"
If MonthNum = 9 Then myMonth = "SEPTEMBER"
If MonthNum = 10 Then myMonth = "OCTOBER"
If MonthNum = 11 Then myMonth = "NOVEMBER"
If MonthNum = 12 Then myMonth = "DECEMBER"
If Cells(4, "J") = myMonth Then 'Determines if any holidays in current MONTH
myDay = Day(Cells(rw1, "J"))
For rw2 = 8 To 23 Step 3
For col = 2 To 8
If myDay = Cells(rw2, col) Then
Cells(rw2, col).Offset(1, 0) = Cells(rw1, "K")
Cells(rw2, col).Offset(2, 0).ClearContents
GoTo PASSEM
End If
Next
Next
End If
PASSEM:
Next
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Sub CalcDay()
Dim d As Integer
Dim dy As Integer
Dim LastDay As Integer
Dim col As Integer
Dim cl As Integer
Dim lday As Integer
Dim n As Integer
Application.ScreenUpdating = False
'Sets the day of the week that is the 1st of the month
d = Application.Weekday(Cells(4, 6) & " 1, " & Cells(4, 8))
Sheet1.Range("B8:H8").ClearContents 'Clears Calendar
LastDay = 8 - d
For dy = 1 To LastDay
col = d + dy
Cells(8, col) = dy
Next dy
'The following sets the days in weeks 2, 3, and 4
Cells(11, 2) = Cells(8, 8) + 1 'Week 2
For n = 3 To 8
Cells(11, n) = Cells(11, n - 1) + 1
Next n
Cells(14, 2) = Cells(11, 2) + 7 'Week 3
For n = 3 To 8
Cells(14, n) = Cells(14, n - 1) + 1
Next n
Cells(17, 2) = Cells(14, 2) + 7 'Week 4
For n = 3 To 8
Cells(17, n) = Cells(17, n - 1) + 1
Next n
'The following sets the days in weeks 5 and 6 dependent on the month and Leap Year
Cells(20, 2) = Cells(17, 8) + 1
For n = 3 To 8
Cells(20, n) = Cells(20, n - 1) + 1
Next n
Cells(23, 2) = Cells(20, 8) + 1
Cells(23, 3) = Cells(23, 2) + 1
If IsLeapYear(Cells(4, 8)) And Cells(4, 6) = "FEBRUARY" Then lday = 29
If Not IsLeapYear(Cells(4, 8)) And Cells(4, 6) = "FEBRUARY" Then lday = 28
If Cells(4, 6) = "APRIL" Then lday = 30
If Cells(4, 6) = "JUNE" Then lday = 30
If Cells(4, 6) = "SEPTEMBER" Then lday = 30
If Cells(4, 6) = "NOVEMBER" Then lday = 30
If Cells(4, 6) = "JANUARY" Then lday = 31
If Cells(4, 6) = "MARCH" Then lday = 31
If Cells(4, 6) = "MAY" Then lday = 31
If Cells(4, 6) = "JULY" Then lday = 31
If Cells(4, 6) = "AUGUST" Then lday = 31
If Cells(4, 6) = "OCTOBER" Then lday = 31
If Cells(4, 6) = "DECEMBER" Then lday = 31
For cl = 2 To 8
If Cells(20, cl) > lday Then Cells(20, cl).ClearContents
If Cells(23, cl) > lday Then Cells(23, cl).ClearContents
Next cl
If Cells(23, 2) = "" Then
Call Remove6thCalendarRow
Else
'Puts borders and fill back if 6th row used
Range("B23:B25").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark1
.TintAndShade = -4.99893185216834E-02
.PatternTintAndShade = 0
End With
Call sixthweek
Range("C23:C25").Select
Call sixthweek
End If
Call MyHolidays
Range("J6").Select
Application.ScreenUpdating = True
End Sub
Public Function IsLeapYear(Y As Integer)
IsLeapYear = Month(DateSerial(Y, 2, 29)) = 2
End Function
Sub Remove6thCalendarRow()
' delete borders in last row
'
Range("B23:C25").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
Selection.Borders(xlEdgeBottom).LineStyle = xlNone
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Range("B22:C22").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
Selection.Borders(xlEdgeTop).LineStyle = xlNone
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Range("B23:B25").Select
With Selection.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End Sub
Sub sixthweek()
' Puts borders back on last (6th) Week
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
'Redate calendar for selected MONTH or if the YEAR is changed
If Target.Address = "$J$4" Then CalcDay
If Target.Address = "$H$4" Then CalcDay
End Sub