将一张工作表中的日期和时间与班次日历进行比较以获取班次

问题似乎出在您的数据而不是代码上。让我们检查工作表中的第一个 Staamp“10/7/2023 8：23.”2023。如果这标志着工作轮班的开始，那么似乎有人迟到了。但是，您能否指定这与哪个班次有关？它可以是 D1 或 D2，因此无法准确确定它是 D1 还是 D2。

或者，这可能是有人加班，可能属于 N1 或 N2 班次。同样，由于数据中的相同歧义，我们无法明确地说它是 N1 还是 N2。

查找数据 （VBA）

Sub PopulateShifts()

    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Write the source values to the source array ('sData').
    
    Dim sws As Worksheet: Set sws = wb.Sheets("Sheet1")
    Dim scCount As Long: scCount = 3 ' Start Time, End Time, Shift
    
    Dim srg As Range, srCount As Long
    
    With sws.Range("A1").CurrentRegion
        srCount = .Rows.Count - 1 ' exclude headers
        Set srg = .Resize(srCount, scCount).Offset(1) ' first 3 columns
    End With
    
    Dim sData() As Variant: sData = srg.Value
    
    ' Shift the data rows containing valid date pairs to the top.
    
    Dim sValue As Variant, sr As Long, sn As Long, sc As Long
    Dim IsInvalidDateFound As Boolean
    
    For sr = 1 To srCount
        If Not IsDate(sData(sr, 1)) Or Not IsDate(sData(sr, 2)) Then
            If IsInvalidDateFound Then
                sn = sn + 1
                For sc = 1 To scCount
                    sData(sn, sc) = sData(sr, sc)
                Next sc
            Else
                IsInvalidDateFound = True
                sn = sr - 1
            End If
        End If
    Next sr
            
    If sn > 0 Then srCount = sn
    
    ' Write the header and values from the destination lookup range
    ' to the destination array ('dData').
    
    Dim dws As Worksheet: Set dws = wb.Sheets("Sheet2")
    Dim dcCount As Long: dcCount = 2 ' Stamp, Shift
    
    Dim drg As Range, drCount As Long
    
    With dws.Range("A1").CurrentRegion
        drCount = .Rows.Count
        Set drg = .Resize(drCount, dcCount) ' first 2 columns
    End With
    
    Dim dData() As Variant: dData = drg.Columns(1).Value
    
    ' In the destination array ('dData'), using the required logic,
    ' replace the destination header and lookup values with the results.
    
    dData(1, 1) = "Shift" ' header
    
    Dim dValue As Variant, dr As Long, IsDateIntervalFound As Boolean
    
    For dr = 2 To drCount
        dValue = dData(dr, 1) ' lookup time
        If IsDate(dValue) Then
            For sr = 1 To srCount
                If dValue < sData(sr, 2) Then ' end
                    If dValue >= sData(sr, 1) Then ' start
                        IsDateIntervalFound = True
                        Exit For
                    End If
                End If
            Next sr
        End If
        If IsDateIntervalFound Then
            IsDateIntervalFound = False
            dData(dr, 1) = sData(sr, 3)
        Else ' not a date or date interval not found
            dData(dr, 1) = Empty
        End If
    Next dr
    
    ' Write the header and the values from the destination array
    ' to the destination result range.
                                
    drg.Columns(2).Value = dData
    
    ' Inform.
    
    MsgBox "Shifts populated.", vbInformation

End Sub

或者，如果移位模式是规则的，则使用逻辑确定。

Option Explicit

Sub FillShift()
    Dim lastrow As Long, r As Long
    With Sheets("Sheet2")
        lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
        For r = 2 To lastrow
            .Cells(r, 2) = GetShift(.Cells(r, 1))
        Next
    End With
    MsgBox lastrow - 1 & " rows filled", vbInformation
End Sub

Function GetShift(dt As Date) As String
    Dim t As Double, s As String, n As String, wd As String
     
    ' mon tue etc
    wd = WeekdayName(Weekday(dt, vbMonday), True)
    t = dt - Int(dt) ' time only
    
    ' Day
    If t >= TimeSerial(6, 0, 0) And t < TimeSerial(18, 0, 0) Then
         s = "D"
         Select Case wd
            Case "Sun", "Mon", "Tue", "Wed"
                n = 1
            Case Else
                n = 2
        End Select
    ' Night
    Else
        s = "N"
        n = 1
        Select Case wd
            Case "Mon", "Tue", "Wed"
                n = "1"
                If wd = "Wed" And t >= TimeSerial(18, 0, 0) Then
                    n = "2"
                End If
            Case Else
                n = "2"
                If wd = "Sun" And t >= TimeSerial(18, 0, 0) Then
                    n = "1"
               End If
        End Select
    End If
    GetShift = s & n
End Function