将分数应用于各个时间段

Question

这些是我的：

Monday to Friday:  
06:00 to 07:30 (2 points per hour)  
14:00 to 17:00 (1 point per hour)  
17:00 to 19:00 (2 points per hour)  
19:00 to 01:00 (3 points per hour)

Saturday  
06:00 to 17:00  (2 points per hour)  
17:00 to 01:00 (3 points per hour)  

Sunday  
06:00 to 17:00 (2 points per hour)  
17:00 to 01:00 (4 points per hour)

Sub CalculateOvertimePoints()
    Dim i As Long
    Dim lastRow As Long
    Dim startTime As Date, endTime As Date
    Dim timeString As String
    Dim duration As Double
    
    ' Get the last row in column E
    lastRow = Cells(Rows.Count, "E").End(xlUp).Row
    
    ' Loop through each row from 30 to the last row
    For i = 30 To lastRow
        timeString = Cells(i, "F").Value
        If InStr(1, timeString, "-") > 0 Then
            startTime = TimeValue(Split(timeString, "-")(0))
            endTime = TimeValue(Split(timeString, "-")(1))
            
            If endTime < startTime Then
                endTime = DateAdd("d", 1, endTime)
            End If

            duration = endTime - startTime
            If duration > 0 Then
                Dim points As Double
                points = 0
                
                Dim currentTime As Date
                currentTime = startTime
                
                While currentTime < endTime
                    Dim nextTime As Date
                    nextTime = DateAdd("n", 30, currentTime)
                    
                    Dim hourPoints As Double
                    hourPoints = 0
                    
                    Select Case Cells(i, "E").Value
                        Case "Monday-Friday"
                            If (currentTime >= TimeValue("06:00") And currentTime < TimeValue("07:30")) Then
                                hourPoints = 1
                            ElseIf (currentTime >= TimeValue("14:00") And currentTime < TimeValue("17:00")) Then
                                hourPoints = 0.5

                            ElseIf (currentTime >= TimeValue("17:00") And currentTime < TimeValue("19:00")) Then
                                hourPoints = 1
                            ElseIf (currentTime >= TimeValue("19:00") Or currentTime < TimeValue("01:00")) Then
                                hourPoints = 1.5
                            End If
                            
                        Case "Saturday"
                            If (currentTime >= TimeValue("06:00") And currentTime < TimeValue("17:00")) Then
                                hourPoints = 1
                                
                            ElseIf (currentTime >= TimeValue("17:00") And currentTime < TimeValue("19:00")) Then
                                hourPoints = 1
                            ElseIf (currentTime >= TimeValue("19:00") Or currentTime < TimeValue("02:00")) Then
                                hourPoints = 1.5
                            End If
                            
                        Case "Sunday"
                            If (currentTime >= TimeValue("06:00") And currentTime < TimeValue("17:00")) Then
                                hourPoints = 2
                            ElseIf (currentTime >= TimeValue("17:00") And currentTime < TimeValue("18:00")) Then
                                hourPoints = 1
                            ElseIf (currentTime >= TimeValue("18:00") And currentTime < TimeValue("19:00")) Then
                                hourPoints = 2
                            End If
                    End Select
                    
                    points = points + hourPoints
                    
                    currentTime = nextTime
                Wend
                
                ' Adjust points based on fractional hours
                Dim fractionalHours As Double
                fractionalHours = (endTime - startTime) * 24 Mod 1
                points = points + fractionalHours * (hourPoints / 60)
                totalPoints = totalPoints - prevHourPoints ' Subtract the last hourPoints value
                totalPoints = totalPoints + fractionalHours * (prevHourPoints / 1) ' Calculate fractional points
                
                Cells(i, "L").Value = points
            Else
                Cells(i, "L").Value = 0
            End If
        Else
            Cells(i, "L").Value = 0
        End If
    Next i
End Sub

代码在某些场景下存在问题。
第一个答案应该是4.5
第二个应该是12
第三个应该是24。

Answer 1

对您的错误进行评论

1. 5.5 是正确的。 1 分/小时 (2 小时 + .5 小时)*1 分/小时 = 2.5 分，2 分/小时组 = (1 小时 + .5 小时)*2 分/小时 = 3 分。总计 2.5+3 = 5.5
2. 我还没有花足够的时间来找出原因，但当 currentTime 和 endTime 均为下午 1:00 时，它会进入 While 循环，即使带有“<" not "<="
3. 1:30 超出了你的规则范围 周六从 [17:00,01:00] 开始..而且我认为你会遇到任何要延续到第二天的范围的问题。

我没有通过计算半小时的“豆子”来计算分数，而是重新编写了它来查找相交的日期时间范围，并计算小时差并应用乘数。

    Sub CalcOTPts()
        Dim startTime As Date, endTime As Date
        Dim timeString As String
        Dim oPts As Double
        
        Dim i As Integer
        For i = 30 To Cells(Rows.Count, "E").End(xlUp).Row
            timeString = Cells(i, "F").Value
            If InStr(1, timeString, "-") > 0 Then
                startTime = TimeValue(Split(timeString, "-")(0))
                endTime = TimeValue(Split(timeString, "-")(1))
                
                If endTime < startTime Then
                    endTime = DateAdd("d", 1, endTime)
                End If
    
                oPts = 0
                Select Case Cells(i, "E").Value
                    Case "Monday-Friday"
                        oPts = oPts + CalcPts(startTime, endTime, "6:00", "7:30", 2)
                        oPts = oPts + CalcPts(startTime, endTime, "14:00", "17:00", 1)
                        oPts = oPts + CalcPts(startTime, endTime, "17:00", "19:30", 2)
                        oPts = oPts + CalcPts(startTime, endTime, "19:00", "01:00", 3)
                    Case "Saturday"
                        oPts = oPts + CalcPts(startTime, endTime, "06:00", "17:00", 2)
                        ' Extended rule to 3:00 to test
                        oPts = oPts + CalcPts(startTime, endTime, "17:00", "03:00", 3)
                    Case "Sunday"
                        oPts = oPts + CalcPts(startTime, endTime, "06:00", "17:00", 3)
                        oPts = oPts + CalcPts(startTime, endTime, "17:00", "01:00", 4)
                End Select
                
                Cells(i, "M").Value = oPts
                
            End If
        Next
    End Sub
    
    
    Private Function CalcPts(ByVal startTime As Date, ByVal endTime As Date, startTimeRule As Date, endTimeRule As Date, multiplier As Double) As Double
        ' Finds the intersecting time between the two ranges and applies the hourly modifier
        
        Dim oStartIntersection As Date
        Dim oEndIntersection As Date
        
        ' Assume it's the next day if the endtime is less than starttime
        If endTimeRule < startTimeRule Then
            endTimeRule = DateAdd("d", 1, endTimeRule)
        End If
        
        CalcPts = 0     ' Default to not add any points
        If (startTime < endTimeRule) And (endTime > startTimeRule) Then
            'There is an intersection beween these two date ranges
            
            ' Find the start time for the intersection
            If startTime > startTimeRule Then
                oStartIntersection = startTime
            Else
                oStartIntersection = startTimeRule
            End If
            
            ' Find the end time for the intersection
            If endTime < endTimeRule Then
                oEndIntersection = endTime
            Else
                oEndIntersection = endTimeRule
            End If
            
            ' Calculate the points
            CalcPts = DateDiff("n", oStartIntersection, oEndIntersection) / 60 * multiplier
        End If
        
    End Function