VBA code not working correctly in some scenario's

Question

Good day,

was hoping someone could help with the following.

this is the criteria:

Monday to Friday:06:00 to 7: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-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)

This is the code:

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

I attached a picture of 3 scenario's - 1Ste answer should be 4.5 second one should be 12 and 3de one should be 24.

Hope someone can help, thank you.

The code has issu's with only some scenario's and I dont understand it, if you change the times to maybe a bit later then it works out correctly.

There's no image. I upvoted your question. Do you now have enough reputation for adding images? — Dominique, Jul 27 '23 at 10:57
Can you clarify what you mean by 'the code has issues' ... does it display an error dialog (if so provide details of the error and at which line) or does it not perform as you expect (again provide details: what it does vs what it should do) — JohnM, Jul 27 '23 at 11:27
Sorry about that , it does not calculate some of the 'times' correctly. like for example: 'Saturday' 07:30-13:30 = '13' points (incorrect) should give me 12 points as it is 6 hours and you get 2 points per hour on a Saturday up-until 17:00 — user8564126, Jul 27 '23 at 13:53
I use 30min intervals to calculate more accurately and most of the time I get the correct result , only some casses that it gives the incorrect results. I will give more examples: 'Monday-Friday' 14:30-18:30 = 5.5 points (incorrect) should be 4.5 points. — user8564126, Jul 27 '23 at 13:59
Take a close look at your `While currentTime < endTime` comparison. I've been doing some testing to try and figure this out, but I'm stumped. For the Saturday 7:00-13:00 case, when `currentTime = 1:00:00 PM` and `endTime = 1:00:00 PM`, the code enters the loop even though it should not. Sorry I can't get more info than that. But this seems to be the source of your problems. — TehDrunkSailor, Jul 27 '23 at 15:56

JosephC · Accepted Answer · 2023-07-27T18:50:26.340

Comments on your error's

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
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 "<="
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

Wow , this is fantastic. Thank you very much for your time & effort! — user8564126, Jul 28 '23 at 06:25

VBA code not working correctly in some scenario's

1 Answers1