Sub Auto_Open()
i = month(Date)
yr = Year(Date)
CalendarMaker i, yr
Sheets("Project Management").Activate
End Sub
Sub CalendarMaker(i As Integer, yr As Integer)
Dim calws As Worksheet, ms_new As Worksheet, mos As Integer, mosname As String, newmos As Integer
Set ms_new = Sheets(Sheets.Count)
mos = i
mosname = (MonthName(mos) & " " & yr)
Application.ScreenUpdating = False
Sheets("Calendar").Activate
Range("a1:g14").Clear
StartDay = DateValue(mosname)
If day(StartDay) <> 1 Then
StartDay = DateValue(month(StartDay) & "/1/" & _
Year(StartDay))
End If
Range("a1").NumberFormat = "mmmm yyyy"
With Range("a1:g1")
.HorizontalAlignment = xlCenterAcrossSelection
.VerticalAlignment = xlCenter
.Font.Size = 24
.Font.Bold = True
.RowHeight = 45
.Interior.Color = RGB(140, 160, 216)
.BorderAround _
Weight:=xlThick, ColorIndex:=xlAutomatic
End With
With Range("a2:g2")
.ColumnWidth = 40
.VerticalAlignment = xlCenter
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Orientation = xlHorizontal
.Font.Size = 13
.Font.Bold = True
.RowHeight = 25
End With
Range("a2") = "Sunday"
Range("b2") = "Monday"
Range("c2") = "Tuesday"
Range("d2") = "Wednesday"
Range("e2") = "Thursday"
Range("f2") = "Friday"
Range("g2") = "Saturday"
With Range("a3:g8")
.HorizontalAlignment = xlRight
.VerticalAlignment = xlTop
.Font.Size = 18
.Font.Bold = True
.RowHeight = 21
End With
Range("a1").Value = Application.Text(mosname, "mmmm yyyy")
DayofWeek = Weekday(StartDay)
CurYear = Year(StartDay)
CurMonth = month(StartDay)
FinalDay = DateSerial(CurYear, CurMonth + 1, 1)
Select Case DayofWeek
Case 1
With Range("a3")
.Value = 1
.Interior.Color = RGB(140, 160, 216)
End With
Case 2
With Range("b3")
.Value = 1
.Interior.Color = RGB(140, 160, 216)
End With
Case 3
With Range("c3")
.Value = 1
.Interior.Color = RGB(140, 160, 216)
End With
Case 4
With Range("d3")
.Value = 1
.Interior.Color = RGB(140, 160, 216)
End With
Case 5
With Range("e3")
.Value = 1
.Interior.Color = RGB(140, 160, 216)
End With
Case 6
With Range("f3")
.Value = 1
.Interior.Color = RGB(140, 160, 216)
End With
Case 7
With Range("g3")
.Value = 1
.Interior.Color = RGB(140, 160, 216)
End With
End Select
For Each cell In Range("a3:g8")
RowCell = cell.Row
ColCell = cell.Column
If cell.Column = 1 And cell.Row = 3 Then
ElseIf cell.Column <> 1 Then
If cell.Offset(0, -1).Value >= 1 Then
cell.Value = cell.Offset(0, -1).Value + 1
cell.Interior.Color = RGB(140, 160, 216)
If cell.Value > (FinalDay - StartDay) Then
cell.Value = ""
cell.ClearContents
cell.Interior.Color = 16777215
Exit For
End If
End If
ElseIf cell.Row > 3 And cell.Column = 1 Then
cell.Value = cell.Offset(-1, 6).Value + 1
cell.Interior.Color = RGB(140, 160, 216)
If cell.Value > (FinalDay - StartDay) Then
cell.Value = ""
Exit For
End If
End If
Next
For x = 0 To 5
Range("A4").Offset(x * 2, 0).EntireRow.Insert
With Range("A4:G4").Offset(x * 2, 0)
.RowHeight = 150
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlTop
.WrapText = True
.Font.Size = 12
.Font.Bold = False
.Interior.Color = 16777215
.Locked = False
End With
With Range("A3").Offset(x * 2, 0).Resize(2, _
7).Borders(xlLeft)
.Weight = xlThick
.ColorIndex = xlAutomatic
End With
With Range("A3").Offset(x * 2, 0).Resize(2, _
7).Borders(xlRight)
.Weight = xlThick
.ColorIndex = xlAutomatic
End With
Range("A3").Offset(x * 2, 0).Resize(2, 7).BorderAround _
Weight:=xlThick, ColorIndex:=xlAutomatic
Next
If Range("A13").Value = "" Then Range("A13").Offset(0, 0) _
.Resize(2, 8).EntireRow.Delete
ActiveWindow.DisplayGridlines = False
ActiveWindow.ScrollRow = 1
Application.ScreenUpdating = True
Find_Info i, yr
Exit Sub
Resume
End Sub
Sub Find_Info(i As Integer, yr As Integer)
Dim r As Integer, c As Range, duedate As String, lastrow As Integer, duerng As Range
Dim ActionTitle As String, duemos As Integer, dueyr As Integer, dueday As Integer, at As Range
With Sheets("Project Management")
lastrow = .Range("A1").End(xlDown).Row + 1
r = 3
Do While r < lastrow
Set c = Sheets("Project Management").Cells.Find("Due Date")
Set at = Sheets("Project Management").Cells.Find("Action Title")
duedate = .Cells(r, c.Column).Value
ActionTitle = .Cells(r, at.Column).Value
duemos = month(duedate)
dueyr = Year(duedate)
dueday = day(duedate)
If duemos = i And dueyr = yr Then
Set duerng = Sheets("Calendar").Cells.Find(dueday)
Set duerng = duerng.Offset(1, 0)
If Not duerng.Value2 = "" Then
duerng.Value2 = duerng.Value2 & Chr(10) & Chr(10) & ActionTitle
Else
duerng.Value2 = ActionTitle
End If
r = r + 1
Else
r = r + 1
End If
Loop
End With
End Sub