Apply score to various time periods

Question

These are my criteria:

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

The code has issues with some scenarios.
First answer should be 4.5
Second one should be 12
Third one should be 24.

Answer 1

Comments on your error's

1. 5.5 is correct. 1pt/hr (2hrs + .5hr)*1pt/hr = 2.5pts, 2pts/hr group = (1hr + .5hr)*2pt/hr = 3pt. Which totals 2.5+3 = 5.5
2. I haven't spent enough time to be able to figure out why but it's entering your While loop when currentTime and endTime are both 1:00 PM, even with a "<" not "<="
3. 1:30 is outside the range of your rules Saturday goes from [17:00,01:00].. also I think you will run into problems with any of your ranges that are going over to the next day.

Instead of counting half-hour "bean's" to tally up your points, I re-wrote it to find intersecting date time ranges and taking the difference in hours and applying your multiplier.

    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