Thread: How do I create a schedule from a list of dates ?

I have a list of project tasks, which are subject to change (e.g. entering a
new task at any point). The tasks are arranged in a list down the worksheet
(so - task, objective, purpose, reporting to, etc). Each task also has a
scheduled action date.
I really want to produce a self updating calendar, based on this list, in a
separate worksheet so that I can see a graphical view of what I have to do
when ! Failing that, a timeline would be useful. I've tried using a Pivot
Table but this doesn't seem to be the way forward. I'd really appreciate any
suggestions.

I played around with this item yesterday and came up with this rock. It may
do what you are looking to accomplish. Operation is based on the following
assumptions:

1. Tasks and Action Dates are located in a worksheet with the name 'Tasks'.
2. Tasks are in a column with the range name 'VBA_Task'.
3. Action Dates are in a column with the range name 'VBA_ActionDate'.
4. Tasks and Action Dates start in row 2.
5. The calendar is placed on worksheet 'Calendar', which has to exist.
6. There is little error checking to verify the assumptions.
7. The calendar will be recreated EVERY time a Task or Action Date is
changed (only these two defined ranges at this time). This behaviour could
take significant time if there are a significant number of tasks. I did not
turn off screen updating, which would speed up the update. Update could be
moved to a command button instead of the Tasks worksheet Change event.
8. The calendar is created with full months overlapping and alternately
colored, similar to Outlook.
9. The First day of the month includes a brief month descriptor.
10. The calendar starts in the month of the earliest task and includes ALL
months through the month of the latest task.
11. Updating the calendar is terminated when a blank date is reached in the
defined range.
12. Tasks and Action Dates line up in corresponding rows.

Trust Nothing. Verify Everything. Use Freely.

I programmed it fairly fast with only a small amount of forethought on speed
of operation, flexibility, etc.

John

Place the following code in a new VBA module:

Option Explicit

Private Months As Variant

'--------------------------------------------------------------------------------------------------
' Routine: DrawCalendar
' Purpose: Draws a calendar starting the the month of the first task
and ending with the month
' of the last task
' Arguments: None
' Returns: N/A
'
' Written by: John Link
' Revised by: John Link
' Last Revied: 06/21/05
'
' Assumptions:
' 1. Monthly calendars overlap (first week of second month starts on same
row as first month).
'--------------------------------------------------------------------------------------------------
Public Sub DrawCalendar()
Dim Weeks As Integer, dFirst As Date, dLast As Date
Dim iYears As Integer, iMonths As Integer, iWeeks As Integer, iCal As
Integer
Dim MonthBegin As Integer, MonthEnd As Integer
Dim ColorMonths As Variant
Dim bOverlap As Boolean, bIsFirst As Boolean, bIsLast As Boolean

iWeeks = 1
iCal = 1
bOverlap = True
bIsFirst = True
bIsLast = False
Months = Array("", "Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul",
"Aug", "Sep", "Oct", "Nov", "Dec")
ColorMonths = Array(RGB(128, 255, 255), RGB(255, 255, 128))

If Not
GetStartEnd(ThisWorkbook.Worksheets("Tasks").Range("VBA_ActionDate"), dFirst,
dLast) Then Exit Sub

SetupCalendar

For iYears = year(dFirst) To year(dLast)
MonthBegin = 1
MonthEnd = 12
If iYears = year(dFirst) Then MonthBegin = month(dFirst)
If iYears = year(dLast) Then MonthEnd = month(dLast)
For iMonths = MonthBegin To MonthEnd
If iYears = year(dLast) And iMonths = MonthEnd Then bIsLast = True
DrawCalendarMonth
ThisWorkbook.Worksheets("Calendar").Range("A2").Cells(iWeeks, 1), _
DateSerial(iYears, iMonths, 1), CLng(ColorMonths(iCal Mod
2)), _
bOverlap, bIsFirst, bIsLast, Weeks
iWeeks = iWeeks + Weeks
iCal = iCal + 1
bIsFirst = False
Next iMonths
Next iYears

PopulateCalendar ThisWorkbook.Worksheets("Calendar").Range("A2"), _
ThisWorkbook.Worksheets("Tasks").Range("VBA_ActionDate"), _
ThisWorkbook.Worksheets("Tasks").Range("VBA_Task"), dFirst

End Sub

'--------------------------------------------------------------------------------------------------
' Routine: SetupCalendar
' Purpose: Clears and sets column configuration
' Arguments: None
' Returns: N/A
'
' Written by: John Link
' Revised by: John Link
' Last Revied: 06/21/05
'
' Assumptions:
' 1. Calendar days are Monday through Sunday.
' 2. Calendar days are in columns A through G.
' 3. The user will not add items to the calendar manually.
'--------------------------------------------------------------------------------------------------
Private Sub SetupCalendar()
Dim Days As Variant, oSheet As Worksheet, iDay As Integer
Days = Array("", "Monday", "Tuesday", "Wednesday", "Thursday", "Friday",
"Saturday", "Sunday")
Set oSheet = ThisWorkbook.Worksheets("Calendar")
With oSheet
With .Range("A1:G65536")
.Clear
.VerticalAlignment = xlTop
.HorizontalAlignment = xlLeft
End With
For iDay = 1 To 7
With .Cells(1, iDay)
.Value = Days(iDay)
.HorizontalAlignment = xlHAlignCenter
.VerticalAlignment = xlVAlignCenter
.Interior.Color = RGB(255, 255, 255)
.BorderAround LineStyle:=xlContinuous, Weight:=xlThin,
Color:=RGB(0, 0, 0)
End With
Next iDay
End With
Set oSheet = Nothing
End Sub

'--------------------------------------------------------------------------------------------------
' Routine: DrawCalendarMonth
' Purpose: Draws a calendar at the specified range for the month
containing the specified date
' Arguments: oRange - Range to draw calendar (upper-left hand corner)
' dDate - Date with month of calendar to draw
' BackColor - Long RGB color value for cell background
(interior) (allow alternating colors)
' bOverlap - Boolean whether the months overlap (i.e., new
month starts on same line as previous month)
' bIsFirst - Boolean whether first month
' bIsLast - Boolean whether last month
' Weeks - Integer for number of weeks added to calendar
(return byRef)
' Returns: (see Weeks)
'
' Written by: John Link
' Revised by: John Link
' Last Revied: 06/21/05
'
' Assumptions:
' 1. The first day of the month will include the name of the month (like
Outlook 31-day view).
' 2. Weekdays names are not included in calendar to be written.
' 3. One row and seven columns per week.
' 4. LineFeed is added after the day.
'--------------------------------------------------------------------------------------------------
Public Sub DrawCalendarMonth(oRange As Range, dDate As Date, BackColor As
Long, _
bOverlap As Boolean, bIsFirst As Boolean, bIsLast As Boolean, _
Weeks As Integer)
Dim iDate As Integer, numDays As Integer, iDay As Integer, iWeek As
Integer
numDays = Day(DateSerial(year(dDate), month(dDate) + 1, 0))
iDay = Weekday(DateSerial(year(dDate), month(dDate), 1), 2)
iWeek = 1
With oRange
If Not bOverlap Or bIsFirst Then
For iDate = 1 To iDay - 1
.Cells(iWeek, iDate).Interior.Color = RGB(128, 128, 128)
.Cells(iWeek, iDate).BorderAround LineStyle:=xlContinuous,
Weight:=xlThin, Color:=RGB(0, 0, 0)
Next iDate
End If
For iDate = 1 To numDays
If iDate = 1 Then
.Cells(iWeek, iDay).Value = Months(month(dDate)) & " " &
iDate & vbLf
Else
.Cells(iWeek, iDay).Value = iDate & vbLf
End If
FormatDateCell .Cells(iWeek, iDay), BackColor
iDay = iDay + 1
If iDay > 7 Then
iDay = 1
iWeek = iWeek + 1
End If
Next iDate
If Not bOverlap Or bIsLast Then
For iDate = iDay To 7
.Cells(iWeek, iDate).Interior.Color = RGB(128, 128, 128)
.Cells(iWeek, iDate).BorderAround LineStyle:=xlContinuous,
Weight:=xlThin, Color:=RGB(0, 0, 0)
Next iDate
End If
End With
Weeks = iWeek
If bOverlap Then
Weeks = Weeks - 1
End If
End Sub

'--------------------------------------------------------------------------------------------------
' Routine: FormatDateCell
' Purpose: Draws a calendar at the specified range for the month
containing the specified date
' Arguments: oRange - Range to format (upper-left hand corner)
' BackColor - Long RGB color value for cell background
' Returns: N/A
'
' Written by: John Link
' Revised by: John Link
' Last Revied: 06/21/05
'
' Assumptions:
' 1. Use the color specified for the cell interior.
' 2. Cell borders are continuous, black, thin lines.
'--------------------------------------------------------------------------------------------------
Private Sub FormatDateCell(oRange As Range, BackColor As Long)
With oRange
.Interior.Color = BackColor
.BorderAround LineStyle:=xlContinuous, Weight:=xlThin, Color:=RGB(0,
0, 0)
End With
End Sub

'--------------------------------------------------------------------------------------------------
' Routine: GetStartEnd
' Purpose: Gets the dates for the first and last tasks
' Arguments: oRange - Range where the dates are located
' dFirst - Date of the first task (return byRef)
' dLast - Date of the last task (return byRef)
' Returns: (see dFirst and dLast)
'
' Written by: John Link
' Revised by: John Link
' Last Revied: 06/21/05
'
' Assumptions:
' 1. Stops reading when there is a blank date.
' 2.
'--------------------------------------------------------------------------------------------------
Private Function GetStartEnd(oRange As Range, dFirst As Date, dLast As Date)
As Boolean
Dim iRow As Integer, iRowStart As Integer
GetStartEnd = False
iRowStart = 2
With oRange
If IsEmpty(.Cells(iRowStart, 1)) Then
MsgBox "There are no dates in the Date range.", vbCritical +
vbOKOnly, "Date Error"
Exit Function
ElseIf Not IsDate(.Cells(iRowStart, 1).Value) Then
MsgBox "A value in the Date range is not a Date: " &
..Cells(iRowStart, 1).Value, vbCritical + vbOKOnly, "Date Error"
Exit Function
End If
dFirst = .Cells(iRowStart, 1).Value
dLast = dFirst
iRow = 3
Do
If .Cells(iRow, 1).Value > dLast Then dLast = .Cells(iRow,
1).Value
If .Cells(iRow, 1).Value < dFirst Then dFirst = .Cells(iRow,
1).Value
iRow = iRow + 1
Loop While Not IsEmpty(.Cells(iRow, 1).Value)
End With
GetStartEnd = True
End Function

'--------------------------------------------------------------------------------------------------
' Routine: PopulateCalendar
' Purpose: Populates the calendar with the task items
' Arguments: oRangeCal - Range where calendar is located
' oRangeDates - Range where the dates are located
' oRangeTasks - Range where the tasks are located
' dFirst - Date of the first task
' Returns: N/A
'
' Written by: John Link
' Revised by: John Link
' Last Revied: 06/21/05
'
' Assumptions:
' 1. Stops reading when there is a blank date.
' 2. Dates start in the second row.
' 3. Task row align with date rows.
'--------------------------------------------------------------------------------------------------
Private Sub PopulateCalendar(oRangeCal As Range, oRangeDates As Range,
oRangeTasks As Range, dFirst As Date)
Dim iRow As Integer, sCell As String
iRow = 2
Do
sCell = CellFromDate(oRangeDates.Cells(iRow, 1), dFirst)
oRangeCal.Range(sCell).Value = oRangeCal.Range(sCell).Value &
oRangeTasks.Cells(iRow, 1) & vbLf
iRow = iRow + 1
Loop While Not IsEmpty(oRangeDates.Cells(iRow, 1))
End Sub

'--------------------------------------------------------------------------------------------------
' Routine: CellFromDate
' Purpose: Determines the cell address for the task date
' Arguments: dTaskDate - Task Date
' dFirst - Date of the first task
' Returns: N/A
'
' Written by: John Link
' Revised by: John Link
' Last Revied: 06/21/05
'
' Assumptions:
' 1.
'--------------------------------------------------------------------------------------------------
Private Function CellFromDate(dTaskDate As Date, dFirst As Date) As String
Dim iDiff As Integer, iRow As Integer, iCol As Integer
iDiff = dTaskDate - DateSerial(year(dFirst), month(dFirst), 1)
iRow = 1 + iDiff \ 7
iCol = Weekday(dFirst, vbMonday) + iDiff Mod 7
If iCol > 7 Then
iCol = iCol - 7
iRow = iRow + 1
End If
CellFromDate = ActiveSheet.Cells(iRow, iCol).Address
End Function

Place the following code in the worksheet where the tasks are located:

'--------------------------------------------------------------------------------------------------
' Routine: Worksheet_Change
' Purpose: Update the Calendar when Task or Action Date is revised
' Arguments: None
' Returns: N/A
'
' Written by: John Link
' Revised by: John Link
' Last Revied: 06/21/05
'
' Assumptions: None
'--------------------------------------------------------------------------------------------------
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = Range("VBA_ActionDate").Column _
Or Target.Column = Range("VBA_Task").Column Then _
DrawCalendar
End Sub


"Gavin Morris" wrote:

> I have a list of project tasks, which are subject to change (e.g. entering a
> new task at any point). The tasks are arranged in a list down the worksheet
> (so - task, objective, purpose, reporting to, etc). Each task also has a
> scheduled action date.
> I really want to produce a self updating calendar, based on this list, in a
> separate worksheet so that I can see a graphical view of what I have to do
> when ! Failing that, a timeline would be useful. I've tried using a Pivot
> Table but this doesn't seem to be the way forward. I'd really appreciate any
> suggestions.