Problem with calendar planner date ranges

[Phil Horwood]

I'm writing an Excel 2003 macro to generate a calendar planner with
coloured worksheet cells forming horizontal bars that show where a
project falls within the year.

However I can't seem to get the logic right to determine whether a
project's date range falls into any given week's column.

Here's a description of what I have:

Column 1 is a list of projects

Column 2 contains the project start dates (not necessarily Sunday
week-ending dates)

Column 3 contains project end dates (not necessarily Sunday week-ending
dates)

Columns 4 to 55 contain the year's 52 Sunday week-ending dates in the
first row and the cells below these are to be coloured if the project's
date range falls into this week. I want the cell shaded if any part of
the project's date range falls into this week.

Can anyone supply me with the comparisons I need to make in order to
determine if a project's date range overlaps the weekly range for a
column on the planner? Any help would be appreciated since my recent
attempts don't seem to pick the right cells. Thanks very much.

 

[Phillip]

'this code assumes the following
'project1 to project7 run from A2 to A8 nothing else in column A
'Project Start dates run from B2 to B8
'Project End dates run from C2 to C8
'week ending sunday dates run from D1 to BC1
'you can have as many projects as you want
'just add them in column A
'The project name must be Project followed by a number
'for this code to work
'I also range named B2:C2 Project1
'B3:C3 Project2 etc

Sub DoColour()

Dim x As Long
Dim z As Long
Dim weeks As Range
Dim Proj As Range
Dim startDate As Date
Dim endDate As Date
Dim dayStart As Integer
Dim dayEnd As Integer
Dim startSun As Date
Dim endSun As Date
Dim StartCell As Long
Dim EndCell As Long
Dim ColourRange As Range

Set weeks = Range("cal") 'week ending Sunday range D1 :BC1
x = Application.CountA(Range("A:A")) 'no of projects
Set weeks = weeks.Offset(1, 0).Resize(x, weeks.Columns.Count)
'clears existing colours
weeks.Interior.ColorIndex = xlColorIndexNone
Set weeks = Range("cal")

'loop projects
For z = 1 To x
Set Proj = Range("project" & z)
startDate = Proj.Cells(1)
endDate = Proj.Cells(2)
dayStart = Weekday(startDate)
dayEnd = Weekday(endDate)
Select Case dayStart
Case 1
startSun = startDate
Case 2, 3, 4, 5, 6, 7
startSun = startDate + (8 - dayStart)
End Select
Select Case dayEnd
Case 1
endSun = endDate
Case 2, 3, 4, 5, 6, 7
endSun = endDate + (8 - dayEnd)
End Select

StartCell = WorksheetFunction.Match(CLng(startSun), weeks, 0)
EndCell = WorksheetFunction.Match(CLng(endSun), weeks, 0)
Set ColourRange =
Range(weeks.Cells(StartCell),weeks.Cells(EndCell)).Offset(z, 0)
ColourRange.Interior.ColorIndex = 3 'red
Next

End Sub

 

[Phil Horwood]

Thanks very much for your help Phillip - much appreciated.