vba 小时和日期范围

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