vba range of hours and dates - excel

Question

hi I have a table that I schedule workers at the workers are scheduled at a range of hours for example 11:00-18:00 and a range of dates for example 21/01/2021-26/01/2021
and I need to spot duplicates for example if the same worker is scheduled at 21/04/2021-22/04/2021 at 11:00:18:00 and 13:00-15:00 it would detect a duplicate schedule
the table looks like this
my code right now spots only exact same schedule duplicate or once that start at the same hour
Private Sub CommandButton1_Click()
Dim lrow As Long
Dim x As Integer
Dim y As Integer
Dim i As Integer
lrow = ActiveSheet.ListObjects("LeaveTracker").DataBodyRange.Rows.Count + 5
shibuzim.ListObjects("LeaveTracker").ListColumns(2).DataBodyRange.Clear
For x = 5 To lrow
For y = x + 1 To lrow
If (Cells(x, 12).Value = Cells(y, 12).Value And _
Cells(x, 13).Value = Cells(y, 13).Value And _
Cells(x, 14).Value = Cells(y, 14).Value And _
Cells(x, 17).Value = Cells(y, 17).Value And _
Cells(x, 18).Value = Cells(y, 18).Value And _
Cells(x, 20).Value = Cells(y, 20).Value) _
Or _
(Cells(x, 12).Value = Cells(y, 12).Value And _
Cells(x, 13).Value = Cells(y, 13).Value And _
Cells(x, 14).Value = Cells(y, 14).Value And _
Left(Cells(x, 17).Value, 3) = Left(Cells(y, 17).Value, 3) And _
Cells(x, 18).Value = Cells(y, 18).Value And _
Cells(x, 20).Value = Cells(y, 20).Value) _
Then
Cells(x, 11).Value = "duplicate"
Cells(y, 11).Value = "duplicate"
MsgBox "line" & " " & x - 4 & " " & "with line" & " " & y - 4
End If
Next y
Next x
End Sub

Answer 1

This create a list of all shifts on a sheet named Check , sorts them by employee, start date, days and then checks them for shifts that start before the previous one ended.
Option Explicit
Sub CheckDupl()
Const COL_DUPL = 2 ' table column 2
Const COl_EMPLOYEE = 3
Const COL_START = 4
Const COL_END = 5
Const COL_HOURS = 8
Dim wb As Workbook, ws As Worksheet, wsCheck As Worksheet
Dim tbl As ListObject, lrow As Long
Dim r As Long, p As Long, iDupl As Long, count As Long
' clear table
Set wb = ThisWorkbook
Set ws = wb.Sheets(1) ' or wb.ActiveSheet
Set tbl = ws.ListObjects("LeaveTracker")
With tbl
lrow = .DataBodyRange.Rows.count
.ListColumns(COL_DUPL).DataBodyRange.Clear
End With
Dim sEmploy As String, s As String
Dim dtStart As Date, dtEnd As Date, dt As Date
Dim bDupl As Boolean, arHours, dur As Single
' prepare output sheet
Set wsCheck = wb.Sheets("Check")
wsCheck.Cells.Clear
wsCheck.Range("A1:F1") = Array("Employee", "Shift Start", "Shift End ", _
"Days", "Table Row", "Duplicate")
' scan table
iDupl = 2
For r = 1 To lrow
sEmploy = Trim(tbl.DataBodyRange(r, COl_EMPLOYEE))
dtStart = tbl.DataBodyRange(r, COL_START)
dtEnd = tbl.DataBodyRange(r, COL_END)
' get shift start/end times
s = Replace(tbl.DataBodyRange(r, COL_HOURS), " ", "") 'remove spaces
If Not s Like "##:##-##:##" Then
MsgBox "Check times '" & s & "'", vbCritical, "Table Row " & r
Exit Sub
Else
arHours = Split(s, "-")
End If
' add each shift to duplicate sheet
dt = dtStart
Do While dt <= dtEnd
With wsCheck.Cells(iDupl, 1)
.Value = sEmploy
.Offset(, 1) = CDate(Format(dt, "yyyy-mm-dd ") & arHours(0))
.Offset(, 2) = CDate(Format(dt, "yyyy-mm-dd ") & arHours(1))
.Offset(, 3) = dtEnd - dtStart
.Offset(, 4) = r ' table row
' sanity check
If .Offset(, 2) - .Offset(, 1) < 0 Then
MsgBox "ERROR - End date before Start date for " & _
sEmploy, vbCritical, "Table Row " & r
Exit Sub
End If
End With
dt = dt + 1
iDupl = iDupl + 1
Loop
Next
iDupl = iDupl - 1
' sort calendar by employee, start date, days
' check longer date ranges against shorter ones
With wsCheck.Sort
With .SortFields
.Clear
.Add key:=Range("A2:A" & iDupl), SortOn:=xlSortOnValues, _
Order:=xlAscending, DataOption:=xlSortNormal
.Add key:=Range("B2:B" & iDupl), SortOn:=xlSortOnValues, _
Order:=xlAscending, DataOption:=xlSortNormal
.Add key:=Range("D1:D" & iDupl), SortOn:=xlSortOnValues, _
Order:=xlDescending, DataOption:=xlSortNormal
End With
.SetRange Range("A1:F" & iDupl)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
' now check for overlaps
With wsCheck
p = 2
For r = 3 To iDupl
' check start is before previous end for same employee
If .Cells(r, 1) = .Cells(p, 1) _
And .Cells(r, 2) < .Cells(p, 3) Then
.Cells(r, 6) = "Overlap with row " & p
' update table
tbl.DataBodyRange(.Cells(r, 5), COL_DUPL) = "Duplicate"
count = count + 1
Else
p = r
End If
Next
.Columns("A:F").AutoFit
.Activate
.Range("A1").Select
End With
MsgBox count & " duplicates found - see sheet " & wsCheck.Name, vbInformation
End Sub