Grab Text associated with a date and insert it within a cell in a Calendar

[PedroDel]

Hello All,

I have a macro that generates a calendar and I really need help taking it to the next step. I have a workbook with two worksheets:

• Tracking - Worksheet that serves as a project tracking sheet. There's a list of items, currently populated with Test 1,2,3,4, etc. Each item will have an estimated date of completion, which is in column G, and a title, which is in column C.
• Completion Calendar - worksheet that houses a calendar that is created with the macro within the file.

THE GOAL - For every item tracked in the Tracking sheet, add the item title (Column C) to the cells in the calendar on the appropriate dates of completion (column G). There may be two items for a particular day. Screens with desired outcome is below:

Tab1.pngTab2.png

Any and all help is tremendously appreciated. I have attached the workbook, and below is the current code of the macro. Please note that so far, the current code only generates the calendar.

Sub CalendarMaker()
ActiveSheet.Protect DrawingObjects:=False, Contents:=False, _
Scenarios:=False
Application.ScreenUpdating = False
On Error GoTo MyErrorTrap
Range("a1:g14").Clear
MyInput = ThisWorkbook.Sheets("Tracking").Range("D1")
If MyInput = "" Then Exit Sub
StartDay = DateValue(MyInput)
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 = 18
.Font.Bold = True
.RowHeight = 125
End With
With Range("a2:g2")
.ColumnWidth = 30
.VerticalAlignment = xlCenter
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Orientation = xlHorizontal
.Font.Size = 12
.Font.Bold = True
.RowHeight = 50
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 = 40
End With
Range("a1").Value = Application.Text(MyInput, "mmmm yyyy")
DayofWeek = Weekday(StartDay)
CurYear = Year(StartDay)
CurMonth = Month(StartDay)
FinalDay = DateSerial(CurYear, CurMonth + 1, 1)
Select Case DayofWeek
Case 1
Range("a3").Value = 1
Case 2
Range("b3").Value = 1
Case 3
Range("c3").Value = 1
Case 4
Range("d3").Value = 1
Case 5
Range("e3").Value = 1
Case 6
Range("f3").Value = 1
Case 7
Range("g3").Value = 1
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
If cell.Value > (FinalDay - StartDay) Then
cell.Value = ""
Exit For
End If
End If
ElseIf cell.Row > 3 And cell.Column = 1 Then
cell.Value = cell.Offset(-1, 6).Value + 1
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 = 95
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlTop
.WrapText = True
.Font.Size = 10
.Font.Bold = False
.Locked = False
End With
With Range("A3").Offset(x * 2, 0).Resize(2, _
7).Borders(xlLeft)
.Weight = xlMedium
.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
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, _
Scenarios:=True
ActiveWindow.WindowState = xlMaximized
ActiveWindow.ScrollRow = 1
Application.ScreenUpdating = True
ActiveSheet.PageSetup.CenterHeader = "&BRA Project Completion Estimates"
Exit Sub
MyErrorTrap:
MsgBox "You may not have entered your Month and Year correctly." _
& Chr(13) & "Spell the Month correctly" _
& " (or use 3 letter abbreviation)" _
& Chr(13) & "and 4 digits for the Year"
MyInput = InputBox("Type in Month and year for Calendar")
If MyInput = "" Then Exit Sub
Resume
End Sub

[nilem]

Hi PedroDel,
try so (see attachment)

[PedroDel]

Nilem, wow, that works! Thank you so much! Is there a way to keep it so that the dates on the calendar only show the day, e.g. "14", versus "12/14/2014"?

Edit: Probably not the best approach, but I accomplished it via adding this to the bottom of your ertert sub:

im r As Range
For Each r In Range("A3:G14").SpecialCells(2)
    r.Resize(2).BorderAround Weight:=xlMedium
Next
Call rtyrty
Range("A3:G3").NumberFormat = "d"
Range("A5:G5").NumberFormat = "d"
Range("A7:G7").NumberFormat = "d"
Range("A9:G9").NumberFormat = "d"
Range("A11:G11").NumberFormat = "d"

Application.ScreenUpdating = True
End Sub

[nilem]

You can set the format of cells on the worksheet once. In this case, there is no need to prescribe the format of the cell in a macro.