Nov 22 2022 07:34 PM
I am using a spreadsheet, to gain visibility on available staff. I have Start Dates and End Dates, creating Dates in the form of a range. I want to use these Date ranges, to auto fill open cells, if the staff member is scheduled during an overlapping range of dates. I would like it to fill the cell red, at a minimum.
Formula to create Date Ranges : =TEXT(B2,"mmm d") & "-" & TEXT(B3,"mmm d")
Any assistance is appreciated.
Nov 25 2022 02:45 PM - edited Nov 25 2022 02:46 PM
@Uranimal Your example date ranges are curious, in that they each overlap -- so all staff member-by-date range cells in a row should be marked as "Unavailable" if any other such cell in that row contains "Assigned".
You don't say it explicitly, but you want the spreadsheet to react to changes in certain (staff member-related) cell content by conditionally changing the content of other cells in that row, based on the new value in the cell and the date ranges, but presumably not dependent on the content of cells for other staff members.
Changing the interior color to red for the "Unavailable" cells could be handled just by using conditional formatting. That's easy to do, though I do not recommend it in this case. And it does not do the date-related calculations that you want.
Determining which date ranges the staff member is unavailable for, and changing those cells to "Unavailable" + red is just part of the logic needed. While it might be possible with lengthy formulas, this situation calls for VBA code and a macro-enabled worksheet (though using code does mean you must think about security). I have written VBA code to do that determination. But beyond that requirement, think through these:
* you or any other person editing the spreadsheet, but I will continue to refer to "you"
** even a misspelling of Assigned (My code ignores differences in capitalization of this special word, and ignores leading and trailing spaces.)
To use the code I have written, you can (cautiously) use the attached workbook. Or, you can review the code below and add it to your workbook:
' The following values/objects, if calculated, do not
' change during one execution of this event handler.
Dim in4BottomStaffRow As Long
Dim in4LastDateColumn As Long
Dim strLastDateColumn As String
Dim objRangeOfInterest As Range
Dim objUpdatedRange As Range 'that portion of the range of _
interest that was updated
' The following values/objects may change multiple times
' during one execution of this event handler.
Dim strCellAddress As String
Dim in4Row As Long
'----
If mblnChangesAreDueToCode Then
Exit Sub
End If
'---- Determine some characteristics of the worksheet.
' Find the bottom data row by looking for the last (consecutive)
' row with a non-blank Staff Member cell.
strCellAddress = strCOL_STAFF_MEMBER & CStr(in4ROW_TOP_OF_STAFF)
in4BottomStaffRow = Range(strCellAddress).End(xlDown).Row
' Find the last data column by looking for the last (consecutive)
' column with a non-blank cell in the row containing Start Dates.
strCellAddress = strCOL_LEFTMOST_DATE & CStr(in4ROW_START_DATE)
in4LastDateColumn = Range(strCellAddress).End(xlToRight).Column
strCellAddress = Cells(1, in4LastDateColumn).Address
strLastDateColumn = Mid$(strCellAddress, 2, _
InStr(2, strCellAddress, "$") - 2)
' --
Set objRangeOfInterest = Range(strCOL_LEFTMOST_DATE _
& CStr(in4ROW_TOP_OF_STAFF) & ":" _
& strLastDateColumn & CStr(in4BottomStaffRow))
'---- See if any of the changed cells are in the range of interest.
Set objUpdatedRange = Intersect(Target, objRangeOfInterest)
If objUpdatedRange Is Nothing Then
'...changes were made to the worksheet, but not within the
' range of interest.
Else
Call RecalculateBlocking(objUpdatedRange, in4LastDateColumn)
End If
9. Go back to the "(General)" section of code. After the "Option Explicit" statement, paste the following code:
'==== CONSTANTS
'---- Structure of the Schedule worksheet:
Private Const in4ROW_START_DATE As Long = 2
Private Const in4ROW_END_DATE As Long = 3
Private Const in4ROW_TOP_OF_STAFF As Long = 6
Private Const strCOL_STAFF_MEMBER As String = "A"
Private Const strCOL_LEFTMOST_DATE As String = "B"
Private Const in4COL_LEFTMOST_DATE As Long = 2
'----
Private Const blnUSE_WORKSHEET_PROTECTION As Boolean = False
'==== MODULE-SCOPE VARIABLES
Private mblnChangesAreDueToCode As Boolean
10. Review the values in the "Private Const" statements at the top, and change them as needed to match your schedule worksheet. If you decide to use worksheet protection, you can later change the value of blnUSE_WORKSHEET_PROTECTION from False to True, but other changes to the worksheet must be made first. Ask about those changes later if interested.
11. Paste the following procedures either before or after the Worksheet_Change procedure:
Function DateRangesOverlap(ByVal StartDate1 As Date, ByVal EndDate1 As Date _
, StartDate2 As Date, EndDate2 As Date) As Boolean
Dim blnReturnValue As Boolean
'----
If StartDate1 >= StartDate2 _
And StartDate1 <= EndDate2 Then
'...the first range starts within the second range.
blnReturnValue = True
ElseIf StartDate2 >= StartDate1 _
And StartDate2 <= EndDate1 Then
'...the second range starts within the first range.
blnReturnValue = True
' These remaining checks are unlikely to be true, but the
' scheduling data could be badly constructed.
ElseIf StartDate1 < StartDate2 _
And EndDate1 > EndDate2 Then
'...the first range completely encompasses the second.
blnReturnValue = True
ElseIf StartDate2 < StartDate1 _
And EndDate2 > EndDate1 Then
'...the second range completely encompasses the first.
blnReturnValue = True
Else
blnReturnValue = False
End If
'----
DateRangesOverlap = blnReturnValue
Exit Function
End Function
Private Sub RecalculateBlocking(ByVal UpdatedRange As Range _
, ByVal LastDateColumn As Long)
' This procedure recalculates availability for the updated rows
' (those included in the specified range).
' Probably only one cell has changed, but the code has to
' assume that multiple cells might have been changed. Also,
' as multiple cells for a staff member may contain "Assigned",
' ...it gets complicated.
Dim in4ColorOfBlockedDates As Long
'
Dim colRowsToRecalc As Collection
Dim vntRow As Variant
Dim in4Row As Long
Dim in4Col As Long
Dim in4ColToRight As Long
'
Dim objCell As Range
Dim strCellContent As String
'
Dim dteCheckStart As Date
Dim dteCheckEnd As Date
Dim dteAssignedStart As Date
Dim dteAssignedEnd As Date
'----
in4ColorOfBlockedDates = vbRed
'...or, an interior color for which it is easier to read black text:
in4ColorOfBlockedDates = RGB(255, 75, 75)
' --
Application.ScreenUpdating = False
'---- Store the row numbers of rows with changes into a
' Collection object.
Set colRowsToRecalc = New Collection
For Each objCell In UpdatedRange
in4Row = objCell.Row
On Error Resume Next '...to handle errors due to duplicates
colRowsToRecalc.Add in4Row, Key:="R" & in4Row
On Error GoTo 0
Next objCell
'---- For each of those rows (in any order)...
If blnUSE_WORKSHEET_PROTECTION Then
ActiveSheet.Unprotect
End If
For Each vntRow In colRowsToRecalc
in4Row = vntRow
If in4Row < in4ROW_TOP_OF_STAFF Then
' This should not happen, but if it does...
GoTo ExamineNextRow
End If
' -- Clear "Unavailable" cells in this row.
in4Col = in4COL_LEFTMOST_DATE
Do
Set objCell = Cells(in4Row, in4Col)
strCellContent = objCell.Value
If StrComp(Trim$(strCellContent), "Unavailable" _
, vbTextCompare) = 0 Then '...found one.
mblnChangesAreDueToCode = True
If blnUSE_WORKSHEET_PROTECTION Then
objCell.Locked = False
End If
objCell.Value = ""
objCell.Interior.Color = Cells(1, in4Col).Interior.Color
mblnChangesAreDueToCode = False
End If
'
in4Col = in4Col + 1
Loop Until in4Col > LastDateColumn
'---- Then, working from left to right, calculate unavailability.
in4Col = in4COL_LEFTMOST_DATE
Do
dteCheckStart = Cells(in4ROW_START_DATE, in4Col).Value
dteCheckEnd = Cells(in4ROW_END_DATE, in4Col).Value
Set objCell = Cells(in4Row, in4Col)
strCellContent = Trim(objCell.Value)
If StrComp(strCellContent, "Assigned", vbTextCompare) = 0 Then
objCell.Interior.Color = Cells(in4ROW_START_DATE _
, in4Col).Interior.Color
GoTo ExamineNextColumn
End If
'
For in4ColToRight = 1 To LastDateColumn
If in4ColToRight = in4Col Then
GoTo NextCheckForOverlap
End If
strCellContent = Cells(in4Row, in4ColToRight).Value
If StrComp(Trim$(strCellContent), "Assigned" _
, vbTextCompare) = 0 Then
dteAssignedStart = Cells(in4ROW_START_DATE, in4ColToRight).Value
dteAssignedEnd = Cells(in4ROW_END_DATE, in4ColToRight).Value
If DateRangesOverlap(dteCheckStart, dteCheckEnd _
, dteAssignedStart, dteAssignedEnd) Then
Set objCell = Cells(in4Row, in4Col)
mblnChangesAreDueToCode = True
objCell.Value = "Unavailable"
objCell.Interior.Color = in4ColorOfBlockedDates
If blnUSE_WORKSHEET_PROTECTION Then
objCell.Locked = True
End If
mblnChangesAreDueToCode = False
Exit For
End If
End If
NextCheckForOverlap:
Next in4ColToRight
ExamineNextColumn:
in4Col = in4Col + 1
Loop Until in4Col > LastDateColumn
ExamineNextRow:
Next vntRow
If blnUSE_WORKSHEET_PROTECTION Then
ActiveSheet.Protect
End If
'
Application.ScreenUpdating = True
End Sub
Private Sub RecalculateBlockingForAll()
' This procedure recalculates date-range blocking for all staff-
' member rows. It is appropriately used if a date range has
' been changed or added
Dim strCellAddress As String
Dim in4LastDateColumn As Long
'---- Find the last data column by looking for the last
' (consecutive) column with a non-blank cell in the
' row containing Start Dates.
strCellAddress = strCOL_LEFTMOST_DATE & CStr(in4ROW_START_DATE)
in4LastDateColumn = Range(strCellAddress).End(xlToRight).Column
'----
Call RecalculateBlocking(ActiveSheet.UsedRange, in4LastDateColumn)
End Sub
Resave the workbook. Then you are ready for testing.
Nov 25 2022 03:23 PM
@Uranimal Your example date ranges are curious, in that they each overlap -- so all staff member-by-date range cells in a row should be marked as "Unavailable" if any other such cell in that row contains "Assigned".
You don't say it explicitly, but you want the spreadsheet to react to changes in certain (staff member-related) cell content by conditionally changing the content of other cells in that row, based on the new value in the cell and the date ranges, but presumably not dependent on the content of cells for other staff members.
Changing the interior color to red for the "Unavailable" cells could be handled just by using conditional formatting. That's easy to do, though I do not recommend it in this case. And it does not do the date-related calculations that you want.
Determining which date ranges the staff member is unavailable for, and changing those cells to "Unavailable" + red is just part of the logic needed. While it might be possible with lengthy formulas, this calls for VBA code and a macro-enabled worksheet (though using code does mean you must think about security). I have written VBA code to do that determination. But beyond that requirement, think through these:
* you or any other person editing the spreadsheet, but I will continue to refer to "you"
** even a misspelling of Assigned (My code ignores differences in capitalization of this special word, and ignores leading and trailing spaces.)
To use the code I have written, you can (cautiously) use the attached workbook.
Or, you can review the code below and add it to your workbook:
' The following values/objects, if calculated, do not
' change during one execution of this event handler.
Dim in4BottomStaffRow As Long
Dim in4LastDateColumn As Long
Dim strLastDateColumn As String
Dim objRangeOfInterest As Range
Dim objUpdatedRange As Range 'that portion of the range of _
interest that was updated
' The following values/objects may change multiple times
' during one execution of this event handler.
Dim strCellAddress As String
Dim in4Row As Long
'----
If mblnChangesAreDueToCode Then
Exit Sub
End If
'---- Determine some characteristics of the worksheet.
' Find the bottom data row by looking for the last (consecutive)
' row with a non-blank Staff Member cell.
strCellAddress = strCOL_STAFF_MEMBER & CStr(in4ROW_TOP_OF_STAFF)
in4BottomStaffRow = Range(strCellAddress).End(xlDown).Row
' Find the last data column by looking for the last (consecutive)
' column with a non-blank cell in the row containing Start Dates.
strCellAddress = strCOL_LEFTMOST_DATE & CStr(in4ROW_START_DATE)
in4LastDateColumn = Range(strCellAddress).End(xlToRight).Column
strCellAddress = Cells(1, in4LastDateColumn).Address
strLastDateColumn = Mid$(strCellAddress, 2, _
InStr(2, strCellAddress, "$") - 2)
' --
Set objRangeOfInterest = Range(strCOL_LEFTMOST_DATE _
& CStr(in4ROW_TOP_OF_STAFF) & ":" _
& strLastDateColumn & CStr(in4BottomStaffRow))
'---- See if any of the changed cells are in the range of interest.
Set objUpdatedRange = Intersect(Target, objRangeOfInterest)
If objUpdatedRange Is Nothing Then
'...changes were made to the worksheet, but not within the
' range of interest.
Else
Call RecalculateBlocking(objUpdatedRange, in4LastDateColumn)
End If
9. Go back to the "(General)" section of code. After the "Option Explicit" statement, paste the following code:
'==== CONSTANTS
'---- Structure of the Schedule worksheet:
Private Const in4ROW_START_DATE As Long = 2
Private Const in4ROW_END_DATE As Long = 3
Private Const in4ROW_TOP_OF_STAFF As Long = 6
Private Const strCOL_STAFF_MEMBER As String = "A"
Private Const strCOL_LEFTMOST_DATE As String = "B"
Private Const in4COL_LEFTMOST_DATE As Long = 2
'----
Private Const blnUSE_WORKSHEET_PROTECTION As Boolean = False
'==== MODULE-SCOPE VARIABLES
Private mblnChangesAreDueToCode As Boolean
10. Review the values in the "Private Const" statements at the top, and change them as needed to match your schedule worksheet. If you decide to use worksheet protection, you can later change the value of blnUSE_WORKSHEET_PROTECTION from False to True, but other changes to the worksheet must be made first. Ask about those changes if you are interested.
11. Paste the following procedures either before or after the Worksheet_Change procedure:
Private Function DateRangesOverlap(ByVal StartDate1 As Date, ByVal EndDate1 As Date _
, StartDate2 As Date, EndDate2 As Date) As Boolean
Dim blnReturnValue As Boolean
'----
If StartDate1 >= StartDate2 _
And StartDate1 <= EndDate2 Then
'...the first range starts within the second range.
blnReturnValue = True
ElseIf StartDate2 >= StartDate1 _
And StartDate2 <= EndDate1 Then
'...the second range starts within the first range.
blnReturnValue = True
' These remaining checks are unlikely to be true, but the
' scheduling data could be badly constructed.
ElseIf StartDate1 < StartDate2 _
And EndDate1 > EndDate2 Then
'...the first range completely encompasses the second.
blnReturnValue = True
ElseIf StartDate2 < StartDate1 _
And EndDate2 > EndDate1 Then
'...the second range completely encompasses the first.
blnReturnValue = True
Else
blnReturnValue = False
End If
'----
DateRangesOverlap = blnReturnValue
Exit Function
End Function
Private Sub RecalculateBlocking(ByVal UpdatedRange As Range _
, ByVal LastDateColumn As Long)
' This procedure recalculates availability for the updated rows
' (those included in the specified range).
' Probably only one cell has changed, but the code has to
' assume that multiple cells might have been changed. Also,
' as multiple cells for a staff member may contain "Assigned",
' ...it gets complicated.
Dim in4ColorOfBlockedDates As Long
'
Dim colRowsToRecalc As Collection
Dim vntRow As Variant
Dim in4Row As Long
Dim in4Col As Long
Dim in4ColToRight As Long
'
Dim objCell As Range
Dim strCellContent As String
'
Dim dteCheckStart As Date
Dim dteCheckEnd As Date
Dim dteAssignedStart As Date
Dim dteAssignedEnd As Date
'----
in4ColorOfBlockedDates = vbRed
'...or, an interior color for which it is easier to read black text:
in4ColorOfBlockedDates = RGB(255, 75, 75)
' --
Application.ScreenUpdating = False
'---- Store the row numbers of rows with changes into a
' Collection object.
Set colRowsToRecalc = New Collection
For Each objCell In UpdatedRange
in4Row = objCell.Row
On Error Resume Next '...to handle errors due to duplicates
colRowsToRecalc.Add in4Row, Key:="R" & in4Row
On Error GoTo 0
Next objCell
'---- For each of those rows (in any order)...
If blnUSE_WORKSHEET_PROTECTION Then
ActiveSheet.Unprotect
End If
For Each vntRow In colRowsToRecalc
in4Row = vntRow
If in4Row < in4ROW_TOP_OF_STAFF Then
' This should not happen, but if it does...
GoTo ExamineNextRow
End If
' -- Clear "Unavailable" cells in this row.
in4Col = in4COL_LEFTMOST_DATE
Do
Set objCell = Cells(in4Row, in4Col)
strCellContent = objCell.Value
If StrComp(Trim$(strCellContent), "Unavailable" _
, vbTextCompare) = 0 Then '...found one.
mblnChangesAreDueToCode = True
If blnUSE_WORKSHEET_PROTECTION Then
objCell.Locked = False
End If
objCell.Value = ""
objCell.Interior.Color = Cells(1, in4Col).Interior.Color
mblnChangesAreDueToCode = False
End If
'
in4Col = in4Col + 1
Loop Until in4Col > LastDateColumn
'---- Then, working from left to right, calculate unavailability.
in4Col = in4COL_LEFTMOST_DATE
Do
dteCheckStart = Cells(in4ROW_START_DATE, in4Col).Value
dteCheckEnd = Cells(in4ROW_END_DATE, in4Col).Value
Set objCell = Cells(in4Row, in4Col)
strCellContent = Trim(objCell.Value)
If StrComp(strCellContent, "Assigned", vbTextCompare) = 0 Then
objCell.Interior.Color = Cells(in4ROW_START_DATE _
, in4Col).Interior.Color
GoTo ExamineNextColumn
End If
'
For in4ColToRight = 1 To LastDateColumn
If in4ColToRight = in4Col Then
GoTo NextCheckForOverlap
End If
strCellContent = Cells(in4Row, in4ColToRight).Value
If StrComp(Trim$(strCellContent), "Assigned" _
, vbTextCompare) = 0 Then
dteAssignedStart = Cells(in4ROW_START_DATE, in4ColToRight).Value
dteAssignedEnd = Cells(in4ROW_END_DATE, in4ColToRight).Value
If DateRangesOverlap(dteCheckStart, dteCheckEnd _
, dteAssignedStart, dteAssignedEnd) Then
Set objCell = Cells(in4Row, in4Col)
mblnChangesAreDueToCode = True
objCell.Value = "Unavailable"
objCell.Interior.Color = in4ColorOfBlockedDates
If blnUSE_WORKSHEET_PROTECTION Then
objCell.Locked = True
End If
mblnChangesAreDueToCode = False
Exit For
End If
End If
NextCheckForOverlap:
Next in4ColToRight
ExamineNextColumn:
in4Col = in4Col + 1
Loop Until in4Col > LastDateColumn
ExamineNextRow:
Next vntRow
If blnUSE_WORKSHEET_PROTECTION Then
ActiveSheet.Protect
End If
Set colRowsToRecalc = Nothing
'----
Application.ScreenUpdating = True
End Sub
Private Sub RecalculateBlockingForAll()
' This procedure recalculates date-range blocking for all staff-
' member rows. It is appropriately used if a date range has
' been changed or added
Dim strCellAddress As String
Dim in4LastDateColumn As Long
'---- Find the last data column by looking for the last
' (consecutive) column with a non-blank cell in the
' row containing Start Dates.
strCellAddress = strCOL_LEFTMOST_DATE & CStr(in4ROW_START_DATE)
in4LastDateColumn = Range(strCellAddress).End(xlToRight).Column
'----
Call RecalculateBlocking(ActiveSheet.UsedRange, in4LastDateColumn)
End Sub
12. Save your changes. Now you are ready for testing.
[Replying again, because my earlier reply has disappeared.]
Nov 25 2022 04:15 PM
Thank you for the amount of time you put into this. The spreadsheet I am using, was to have a pre-scheduling tool. Rather than fight with error messages and then trying to see where I need to make changes, in the current scheduling software. The current scheduling software, pulls the employees from availability, when they are on vacation/sick. Making it easier to schedule in the event they are out for whatever other reason. It just doesn't remove the individuals, if they are already scheduled. I had hoped, it would be a simple If>Then set of codes. I will take your information, and see how well I can implement it, and I appreciate the emphasis on being cautious.