How to modify code to include a duration?

[timleonard]

How can the following code to be modified to include a duration Column or "Named Range"?

I would like to modify it so that a task that has a duration for example, three to five days would show the same task in the calendar on the corresponding days of the week .
I believe the area to be modified is between line 250 and 282...

Could someone point out the required changes to be made

Thanks for any help you could offer

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).Font.Bold = True
.Cells(iWeek, iDay).Font.Size = 12
.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
oRangeCal.Range(sCell).Characters(6, 1000).Font.Bold = False
oRangeCal.Range(sCell).Characters(6, 1000).Font.Size = 10
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
 
 

[Guido Geurs]

Please is it possible to attach in Bytes the sheet with the data so we have something to work on .
!! XLS files must be ZIPPED !!

[timleonard]

Thank you for responding, I really appreciate it. Attached is the file for reference. As stated I would like to add a field for a duration. If a task is scheduled for let's say three days (or for 24 hours) then it would show three days on the calendar.

[Guido Geurs]

I have analyzed the code.
You want that for example a task that starts on 1-2-2010 and has a duration of 50 hours, this will be represented in (50/8=6.25 days) 7 cells (1-2-2010,2-2..,...,7-2-2010)?
If so, You have to send to the sub "PopulateCalendar" also the range HOURS.
In the Sub "PopulateCalendar" You have to loop until 7 in "oRangeDates.Cells(iRow, 1)" and calculate the 7 "sCell" and add the data in these cells.

Is this way of thinking OK for You?

[timleonard]

Yes that is what I was thinking, however is there a way to choose weekend or not when modifying the code? Perhaps a checkbox in the column after the hours to populate the weekend?

[Guido Geurs]

I have added: (see attachment)
- the loop for setting the data in function of the duration.
- A column for weekend work (Y/N)
- the loop for taking account of the weekend work.
- assigned the button to the macro.

I hope this will help You.

[timleonard]

This is nice work...

Thank you so much for your help...I would never have figured it out

[timleonard]

I added a some formating to it and a labor schedule(Around line 80) Now I am noticing that there seems to be an issue around what date is being populated. If for example a date of January 20th is used it populates the calendar on the 19th. This must be due to something I did but I cant figure out from where or what.

Could you please take a look and see if you find the problem

[Guido Geurs]

There is nothing wrong in what You have done according to the set-up of the calendar.
There is an error in the calculation of the "CellFromDate" from the beginning!
If You change the date to 14-Jan-2010 in the first file You have send to me, then the data will be placed on the 13e !
I will see if I can find the error but it's a complex calculation for just finding the Row and Col value.
I will also see if there is an other way with "array's" so we can eliminate these calculations.
It's a whole different approach in setting up the calendar.

[Guido Geurs]

This is an other way of setting-up the calendar.(No need for column with calendar-data !).
How it works:
- Put the data from the sheet "Tasks" in an array "ARRinput".
- Calculate the first and last day and remember the dates for the jobs in an extra column in the "ARRin".
- Fill an "ARRdates" with the dates needed.
- Set-up an array with the same dimentions as the ARRcalendar.
- fill the ARRout with the dates and the data of the jobs with as references for Row and Col the ARRcalendar.
- Dump the ARRout in the sheet "Calendar".
- Format the cells in the sheet "Calendar".

[timleonard]

Awsome Work....Works Great

Thank you so much for your help!!!