By using this site, you agree to our updated Privacy Policy and our Terms of Use. Manage your Cookies Settings.
435,089 Members | 1,964 Online
Bytes IT Community
+ Ask a Question
Need help? Post your question and get tips & solutions from a community of 435,089 IT Pros & Developers. It's quick & easy.

How to modify code to include a duration?

P: 52
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

Expand|Select|Wrap|Line Numbers
  1. Option Explicit
  2.  
  3. Private Months As Variant
  4.  
  5. '--------------------------------------------------------------------------------------------------
  6. ' Routine: DrawCalendar
  7. ' Purpose: Draws a calendar starting the the month of the first task and ending with the month
  8. ' of the last task
  9. ' Arguments: None
  10. ' Returns: N/A
  11. '
  12. ' Written by: John Link
  13. ' Revised by: John Link
  14. ' Last Revied: 06/21/05
  15. '
  16. ' Assumptions:
  17. ' 1. Monthly calendars overlap (first week of second month starts on same row as first month).
  18. '--------------------------------------------------------------------------------------------------
  19. Public Sub DrawCalendar()
  20. Dim Weeks As Integer, dFirst As Date, dLast As Date
  21. Dim iYears As Integer, iMonths As Integer, iWeeks As Integer, iCal As Integer
  22. Dim MonthBegin As Integer, MonthEnd As Integer
  23. Dim ColorMonths As Variant
  24. Dim bOverlap As Boolean, bIsFirst As Boolean, bIsLast As Boolean
  25.  
  26. iWeeks = 1
  27. iCal = 1
  28. bOverlap = True
  29. bIsFirst = True
  30. bIsLast = False
  31. Months = Array("", "Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec")
  32. ColorMonths = Array(RGB(128, 255, 255), RGB(255, 255, 128))
  33.  
  34. If Not GetStartEnd(ThisWorkbook.Worksheets("Tasks").Range("VBA_ActionDate"), dFirst, dLast) Then Exit Sub
  35.  
  36. SetupCalendar
  37.  
  38. For iYears = Year(dFirst) To Year(dLast)
  39. MonthBegin = 1
  40. MonthEnd = 12
  41. If iYears = Year(dFirst) Then MonthBegin = Month(dFirst)
  42. If iYears = Year(dLast) Then MonthEnd = Month(dLast)
  43. For iMonths = MonthBegin To MonthEnd
  44. If iYears = Year(dLast) And iMonths = MonthEnd Then bIsLast = True
  45.  
  46. DrawCalendarMonth ThisWorkbook.Worksheets("Calendar").Range("A2").Cells(iWeeks, 1), _
  47. DateSerial(iYears, iMonths, 1), CLng(ColorMonths(iCal Mod 2)), _
  48. bOverlap, bIsFirst, bIsLast, Weeks
  49. iWeeks = iWeeks + Weeks
  50. iCal = iCal + 1
  51. bIsFirst = False
  52. Next iMonths
  53. Next iYears
  54.  
  55.  
  56. PopulateCalendar ThisWorkbook.Worksheets("Calendar").Range("A2"), _
  57. ThisWorkbook.Worksheets("Tasks").Range("VBA_ActionDate"), _
  58. ThisWorkbook.Worksheets("Tasks").Range("VBA_Task"), dFirst
  59.  
  60. End Sub
  61.  
  62. '--------------------------------------------------------------------------------------------------
  63. ' Routine: SetupCalendar
  64. ' Purpose: Clears and sets column configuration
  65. ' Arguments: None
  66. ' Returns: N/A
  67. '
  68. ' Written by: John Link
  69. ' Revised by: John Link
  70. ' Last Revied: 06/21/05
  71. '
  72. ' Assumptions:
  73. ' 1. Calendar days are Monday through Sunday.
  74. ' 2. Calendar days are in columns A through G.
  75. ' 3. The user will not add items to the calendar manually.
  76. '--------------------------------------------------------------------------------------------------
  77. Private Sub SetupCalendar()
  78.  
  79. Dim Days As Variant, oSheet As Worksheet, iDay As Integer
  80. Days = Array("", "Monday", "Tuesday", "Wednesday", "Thursday", "Friday", "Saturday", "Sunday")
  81. Set oSheet = ThisWorkbook.Worksheets("Calendar")
  82. With oSheet
  83. With .Range("A1:G65536")
  84. .Clear
  85. .VerticalAlignment = xlTop
  86. .HorizontalAlignment = xlLeft
  87. End With
  88. For iDay = 1 To 7
  89. With .Cells(1, iDay)
  90. .Value = Days(iDay)
  91. .HorizontalAlignment = xlHAlignCenter
  92. .VerticalAlignment = xlVAlignCenter
  93. .Interior.Color = RGB(255, 255, 255)
  94. .BorderAround LineStyle:=xlContinuous, Weight:=xlThin, Color:=RGB(0, 0, 0)
  95. End With
  96. Next iDay
  97. End With
  98. Set oSheet = Nothing
  99.  
  100. End Sub
  101.  
  102. '--------------------------------------------------------------------------------------------------
  103. ' Routine: DrawCalendarMonth
  104. ' Purpose: Draws a calendar at the specified range for the month containing the specified date
  105. ' Arguments: oRange - Range to draw calendar (upper-left hand corner)
  106. ' dDate - Date with month of calendar to draw
  107. ' BackColor - Long RGB color value for cell background (interior) (allow alternating colors)
  108. ' bOverlap - Boolean whether the months overlap (i.e., new month starts on same line as previous month)
  109. ' bIsFirst - Boolean whether first month
  110. ' bIsLast - Boolean whether last month
  111. ' Weeks - Integer for number of weeks added to calendar (return byRef)
  112. ' Returns: (see Weeks)
  113. '
  114. ' Written by: John Link
  115. ' Revised by: John Link
  116. ' Last Revied: 06/21/05
  117. '
  118. ' Assumptions:
  119. ' 1. The first day of the month will include the name of the month (like Outlook 31-day view).
  120. ' 2. Weekdays names are not included in calendar to be written.
  121. ' 3. One row and seven columns per week.
  122. ' 4. LineFeed is added after the day.
  123. '--------------------------------------------------------------------------------------------------
  124. Public Sub DrawCalendarMonth(oRange As Range, dDate As Date, BackColor As Long, _
  125. bOverlap As Boolean, bIsFirst As Boolean, bIsLast As Boolean, _
  126. Weeks As Integer)
  127. Dim iDate As Integer, numDays As Integer, iDay As Integer, iWeek As Integer
  128. numDays = Day(DateSerial(Year(dDate), Month(dDate) + 1, 0))
  129. iDay = Weekday(DateSerial(Year(dDate), Month(dDate), 1), 2)
  130. iWeek = 1
  131. With oRange
  132. If Not bOverlap Or bIsFirst Then
  133. For iDate = 1 To iDay - 1
  134. .Cells(iWeek, iDate).Interior.Color = RGB(128, 128, 128)
  135. .Cells(iWeek, iDate).BorderAround LineStyle:=xlContinuous, Weight:=xlThin, Color:=RGB(0, 0, 0)
  136. Next iDate
  137. End If
  138. For iDate = 1 To numDays
  139. If iDate = 1 Then
  140. .Cells(iWeek, iDay).Font.Bold = True
  141. .Cells(iWeek, iDay).Font.Size = 12
  142. .Cells(iWeek, iDay).Value = Months(Month(dDate)) & " " & iDate & vbLf
  143. Else
  144. .Cells(iWeek, iDay).Value = iDate & vbLf
  145. End If
  146. FormatDateCell .Cells(iWeek, iDay), BackColor
  147. iDay = iDay + 1
  148. If iDay > 7 Then
  149. iDay = 1
  150. iWeek = iWeek + 1
  151. End If
  152. Next iDate
  153. If Not bOverlap Or bIsLast Then
  154. For iDate = iDay To 7
  155. .Cells(iWeek, iDate).Interior.Color = RGB(128, 128, 128)
  156. .Cells(iWeek, iDate).BorderAround LineStyle:=xlContinuous, Weight:=xlThin, Color:=RGB(0, 0, 0)
  157. Next iDate
  158. End If
  159. End With
  160. Weeks = iWeek
  161. If bOverlap Then
  162. Weeks = Weeks - 1
  163. End If
  164. End Sub
  165.  
  166. '--------------------------------------------------------------------------------------------------
  167. ' Routine: FormatDateCell
  168. ' Purpose: Draws a calendar at the specified range for the month containing the specified date
  169. ' Arguments: oRange - Range to format (upper-left hand corner)
  170. ' BackColor - Long RGB color value for cell background
  171. ' Returns: N/A
  172. '
  173. ' Written by: John Link
  174. ' Revised by: John Link
  175. ' Last Revied: 06/21/05
  176. '
  177. ' Assumptions:
  178. ' 1. Use the color specified for the cell interior.
  179. ' 2. Cell borders are continuous, black, thin lines.
  180. '--------------------------------------------------------------------------------------------------
  181. Private Sub FormatDateCell(oRange As Range, BackColor As Long)
  182. With oRange
  183. .Interior.Color = BackColor
  184. .BorderAround LineStyle:=xlContinuous, Weight:=xlThin, Color:=RGB(0, 0, 0)
  185. End With
  186. End Sub
  187.  
  188. '--------------------------------------------------------------------------------------------------
  189. ' Routine: GetStartEnd
  190. ' Purpose: Gets the dates for the first and last tasks
  191. ' Arguments: oRange - Range where the dates are located
  192. ' dFirst - Date of the first task (return byRef)
  193. ' dLast - Date of the last task (return byRef)
  194. ' Returns: (see dFirst and dLast)
  195. '
  196. ' Written by: John Link
  197. ' Revised by: John Link
  198. ' Last Revied: 06/21/05
  199. '
  200. ' Assumptions:
  201. ' 1. Stops reading when there is a blank date.
  202. ' 2.
  203. '--------------------------------------------------------------------------------------------------
  204. Private Function GetStartEnd(oRange As Range, dFirst As Date, dLast As Date) As Boolean
  205. Dim iRow As Integer, iRowStart As Integer
  206. GetStartEnd = False
  207. iRowStart = 2
  208. With oRange
  209. If IsEmpty(.Cells(iRowStart, 1)) Then
  210. MsgBox "There are no dates in the Date range.", vbCritical + vbOKOnly, "Date Error"
  211. Exit Function
  212. ElseIf Not IsDate(.Cells(iRowStart, 1).Value) Then
  213. MsgBox "A value in the Date range is not a Date: " & .Cells(iRowStart, 1).Value, vbCritical + vbOKOnly, "Date Error"
  214. Exit Function
  215. End If
  216. dFirst = .Cells(iRowStart, 1).Value
  217. dLast = dFirst
  218. iRow = 3
  219. Do
  220. If .Cells(iRow, 1).Value > dLast Then dLast = .Cells(iRow, 1).Value
  221. If .Cells(iRow, 1).Value < dFirst Then dFirst = .Cells(iRow, 1).Value
  222. iRow = iRow + 1
  223. Loop While Not IsEmpty(.Cells(iRow, 1).Value)
  224. End With
  225. GetStartEnd = True
  226. End Function
  227.  
  228. '--------------------------------------------------------------------------------------------------
  229. ' Routine: PopulateCalendar
  230. ' Purpose: Populates the calendar with the task items
  231. ' Arguments: oRangeCal - Range where calendar is located
  232. ' oRangeDates - Range where the dates are located
  233. ' oRangeTasks - Range where the tasks are located
  234. ' dFirst - Date of the first task
  235. ' Returns: N/A
  236. '
  237. ' Written by: John Link
  238. ' Revised by: John Link
  239. ' Last Revied: 06/21/05
  240. '
  241. ' Assumptions:
  242. ' 1. Stops reading when there is a blank date.
  243. ' 2. Dates start in the second row.
  244. ' 3. Task row align with date rows.
  245. '--------------------------------------------------------------------------------------------------
  246. Private Sub PopulateCalendar(oRangeCal As Range, oRangeDates As Range, oRangeTasks As Range, dFirst As Date)
  247. Dim iRow As Integer, sCell As String
  248. iRow = 2
  249. Do
  250. sCell = CellFromDate(oRangeDates.Cells(iRow, 1), dFirst)
  251. oRangeCal.Range(sCell).Value = oRangeCal.Range(sCell).Value & "--" & " " & oRangeTasks.Cells(iRow, 1) & vbLf
  252. oRangeCal.Range(sCell).Characters(6, 1000).Font.Bold = False
  253. oRangeCal.Range(sCell).Characters(6, 1000).Font.Size = 10
  254. iRow = iRow + 1
  255. Loop While Not IsEmpty(oRangeDates.Cells(iRow, 1))
  256. End Sub
  257.  
  258. '--------------------------------------------------------------------------------------------------
  259. ' Routine: CellFromDate
  260. ' Purpose: Determines the cell address for the task date
  261. ' Arguments: dTaskDate - Task Date
  262. ' dFirst - Date of the first task
  263. ' Returns: N/A
  264. '
  265. ' Written by: John Link
  266. ' Revised by: John Link
  267. ' Last Revied: 06/21/05
  268. '
  269. ' Assumptions:
  270. ' 1.
  271. '--------------------------------------------------------------------------------------------------
  272. Private Function CellFromDate(dTaskDate As Date, dFirst As Date) As String
  273. Dim iDiff As Integer, iRow As Integer, iCol As Integer
  274. iDiff = dTaskDate - DateSerial(Year(dFirst), Month(dFirst), 1)
  275. iRow = 1 + iDiff \ 7
  276. iCol = Weekday(dFirst, vbMonday) + iDiff Mod 7
  277. If iCol > 7 Then
  278. iCol = iCol - 7
  279. iRow = iRow + 1
  280. End If
  281. CellFromDate = ActiveSheet.Cells(iRow, iCol).Address
  282. End Function
  283.  
  284. 'Place the following code in the worksheet where the tasks are located:
  285.  
  286. '--------------------------------------------------------------------------------------------------
  287. ' Routine: Worksheet_Change
  288. ' Purpose: Update the Calendar when Task or Action Date is revised
  289. ' Arguments: None
  290. ' Returns: N/A
  291. '
  292. ' Written by: John Link
  293. ' Revised by: John Link
  294. ' Last Revied: 06/21/05
  295. '
  296. ' Assumptions: None
  297. '--------------------------------------------------------------------------------------------------
  298. Private Sub Worksheet_Change(ByVal Target As Range)
  299. If Target.Column = Range("VBA_ActionDate").Column _
  300. Or Target.Column = Range("VBA_Task").Column Then _
  301. DrawCalendar
  302. End Sub
  303.  
  304.  
Oct 28 '10 #1

✓ answered by 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.

Share this Question
Share on Google+
10 Replies


Guido Geurs
Expert 100+
P: 767
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 !!
Oct 29 '10 #2

P: 52
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.
Attached Files
File Type: zip Engineering Schedule.zip (321.6 KB, 48 views)
Nov 1 '10 #3

Guido Geurs
Expert 100+
P: 767
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?
Nov 3 '10 #4

P: 52
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?
Nov 4 '10 #5

Guido Geurs
Expert 100+
P: 767
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.
Attached Files
File Type: zip How to modify code to include a duration_v6.zip (266.5 KB, 40 views)
Nov 4 '10 #6

P: 52
This is nice work...

Thank you so much for your help...I would never have figured it out
Nov 4 '10 #7

P: 52
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
Attached Files
File Type: zip How to modify code to include a duration_v6 .zip (267.9 KB, 36 views)
Nov 7 '10 #8

Guido Geurs
Expert 100+
P: 767
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.
Nov 8 '10 #9

Guido Geurs
Expert 100+
P: 767
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".
Nov 16 '10 #10

P: 52
Awsome Work....Works Great

Thank you so much for your help!!!
Nov 17 '10 #11

Post your reply

Sign in to post your reply or Sign up for a free account.