Excel - across and down matches - vba

Question

I have a workbook with two sheets in it, the first looks like this:
--------------------------------------------------------
Last Name | First Name | 1-Jan | 2-Jan | 3-Jan | 4-Jan | (continues on like this)
--------------------------------------------------------
SMITH | John | 1 | 1 | | |
--------------------------------------------------------
BOND | James | | | 1 | 1 |
--------------------------------------------------------
Second sheet
--------------------------------------------------------
| January | February | (continues on etc)
--------------------------------------------------------
Last Name | First Name | From | To | From | To |
--------------------------------------------------------
SMITH | John |1/1/18 | 2/2/18| | |
--------------------------------------------------------
BOND | James |3/1/18 |4/1/18 | | |
--------------------------------------------------------
This is a leave sheet and basically the user inputs on the first sheet a '1' in the day where they are taking leave. This is then automatically updated in the second sheet to reflect the inclusive dates of their leave for each month.
So in the first example, user enters 1 in 1-Jan and 2-Jan, this updates second sheet with leave for that employee from 1/1/18 to 2/1/18.
So far, I'm successful in being able to detect when a 1 is entered it grabs the name and date details, I've been using a msgbox to verify that I'm getting the right data.
The problem I'm having is that's as far as I can get, I can't work out how to search the second sheet to find the dates and update accordingly.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range
' The variable KeyCells contains the cells that will
' cause an alert when they are changed.
Set KeyCells = Range("D6:OI53")
If Not Application.Intersect(KeyCells, Range(Target.Address)) _
Is Nothing Then
' If cell changed, do the below '
' Get name '
Dim lastName As String
Dim firstName As String
lastName = ActiveSheet.Cells(Target.Cells.Row, 1).Value
firstName = ActiveSheet.Cells(Target.Cells.Row, 2).Value
'Get date '
Dim leaveDate As String
leaveDate = ActiveSheet.Cells(5, Target.Cells.Column).Value
' Test lastname, firstname, date '
UpdateMonthlyLeave lastName, firstName, leaveDate
End If
End Sub
Sub UpdateMonthlyLeave(lastName As String, firstName As String, leaveDate As String)
MsgBox lastName & " " & firstName & " " & leaveDate
' Find employee on monthly leave sheet '
End Sub

Answer 1

This UDF will return a list of start OR end dates. Just make you you select Wrap Text for the columns in sheet 2. I think one advantage may be Excel would only update the cell with the formula if the ranges it specifies are changed.
Perhaps the code could be simplified further, but unfortunately you will have to enter the formula for each cell in sheet2.
Option Explicit
' ShowStartMonth: True If we need to return the start date of the holidays
' MonthRange: The WHOLE Column range of the Month
' RowRange: The Range of the person's row but only the holiday columns, not the name columns
' MonthNameRow: The entire row of where the Month name is
Public Function GetHoliday(ShowStartMonth As Boolean, iMonth As Integer, RowRange As Range, MonthNameRow As Range) As String
Dim MonthRange As Range
Set MonthRange = GetMonthRange(iMonth, MonthNameRow)
'Init variables
' Get the cells for the current month
Dim rRow As Range
Set rRow = Intersect(RowRange, RowRange.Worksheet.UsedRange, MonthRange)
Dim IsCurrentCellHoliday As Boolean
Dim IsLastCellHoliday As Boolean
Dim IsStartHolidayContinuation As Boolean
' If First Day of month is a holiday and last day of last month is a holiday then
' Holiday is continuation
IsStartHolidayContinuation = (rRow.Cells(1).Value = 1) And (rRow.Cells(1).Offset(0, -1).Value = 1)
IsLastCellHoliday = (rRow.Cells(1).Value = 1)
' These will hold the dates for start or end of a holiday
Dim StartDays() As String
Dim EndDays() As String
ReDim StartDays(0 To 255)
ReDim EndDays(0 To 255)
Dim SDIndex As Integer ' Index of the start day array
Dim EDIndex As Integer ' Index of the end day array
' If Start of month is start of a new holiday then set it
If (IsLastCellHoliday And Not IsStartHolidayContinuation) Then StartDays(0) = GetMonthName(rRow.Cells(1), MonthNameRow)
' If start of month is a holiday then set index to the second "StartHoliday" line
SDIndex = IIf(IsStartHolidayContinuation Or IsLastCellHoliday, 1, 0) ' Keep first row Empty if start of month is holiday
EDIndex = 0
' Loop through all cells in the month for the person
Dim i As Integer
For i = SDIndex + 1 To rRow.Columns.Count
Dim rCell As Range
Set rCell = rRow.Cells(i)
IsCurrentCellHoliday = rCell.Value = 1 'Check if current cell is a holiday
' If the current cell is different to the last cell then we need to do something
If IsCurrentCellHoliday <> IsLastCellHoliday Then
If IsCurrentCellHoliday Then
StartDays(SDIndex) = GetMonthName(rCell, MonthNameRow)
SDIndex = SDIndex + 1
' Check if the first day of the next month is a holiday, if not then today is the last day
If rCell.Column = MonthRange.Columns(MonthRange.Columns.Count).Column And rCell.Offset(0, 1).Value <> 1 Then
EndDays(EDIndex) = GetMonthName(rRow.Cells(i), MonthNameRow)
EDIndex = EDIndex + 1
End If
Else
EndDays(EDIndex) = GetMonthName(rRow.Cells(i - 1), MonthNameRow)
EDIndex = EDIndex + 1
End If
End If
IsLastCellHoliday = IsCurrentCellHoliday
Next
Dim ReturnStrings() As String
Dim ReturnIndex As Integer
If (ShowStartMonth) Then
ReturnStrings = StartDays
ReturnIndex = SDIndex
Else
ReturnStrings = EndDays
ReturnIndex = EDIndex
End If
Dim returnString As String
returnString = IIf(Len(ReturnStrings(0)) = 0, " - ", ReturnStrings(0))
Dim j As Integer
For j = LBound(ReturnStrings) + 1 To ReturnIndex - 1
returnString = returnString & vbNewLine & ReturnStrings(j)
Next
GetHoliday = returnString
End Function
Private Function GetMonthName(cell As Range, MonthRow As Range) As String
Dim rMonth As Range
Set rMonth = Intersect(cell.EntireColumn, MonthRow.EntireRow)
End Function
Public Function GetMonthRange(iMonth As Integer, MonthNameRow As Range) As Range
Set MonthNameRow = Intersect(MonthNameRow.EntireRow, MonthNameRow.Worksheet.UsedRange)
Dim startCell As Range
Dim endCell As Range
Dim rCell As Range
For Each rCell In MonthNameRow.Cells
If IsDate(rCell.Value) Then
If month(CDate(rCell.Value)) = iMonth Then
If startCell Is Nothing Then
Set startCell = rCell
ElseIf rCell.Column < startCell.Column Then
Set startCell = rCell
End If
If endCell Is Nothing Then
Set endCell = rCell
ElseIf rCell.Column > endCell.Column Then
Set endCell = rCell
End If
End If
End If
Next
Set GetMonthRange = Range(startCell.Address & ":" & endCell.Address).EntireColumn
Dim sAddress As String
sAddress = GetMonthRange.Address
End Function