Please help with Time Rounding (1 Viewer)

[slharman1]

I have copied the following code from another thread, post #4, the thread is located here:

roundup or down to the nearest half is it possible?

Hi I'm wandering if it's possible to get access to round numbers to the nearest 1/2 hour i.e. 0.5, 1.5 or 2.0 depending on the result. Any help much appreciated. Oh by the way I'm using 2003.

www.access-programmers.co.uk

It is not working , please help

Public Function RoundTime(varTime As Variant, Optional ByVal lngSeconds As Long = 900&) As Variant

'The function below rounds a date/time value to the specified number of seconds. For example, to round to the nearest half hour (30 * 60 seconds), use:
'    =RoundTime([MyDateTimeField], 1800)

    'Purpose:   Round a date/time value to the nearest number of seconds
    'Arguments: varTime = the date/time value
    '           lngSeconds = number of seconds to round to.
    '               e.g.  60 for nearest minute,
    '                    600 for nearest 10 minutes,
    '                   3600 for nearest hour,
    '                  86400 for nearest day.
    'Return:    Rounded date/time value, or Null if no date/time passed in.
    'Note:      lngSeconds must be between 1 and 86400.
    '           Default rounds is nearest 15 minutes.
    Dim lngSecondsOffset As Long
    
    RoundTime = Null        'Initialize to return Null.
    If Not IsError(varTime) Then
        If IsDate(varTime) Then
            If (lngSeconds < 1&) Or (lngSeconds > 86400) Then
                lngSeconds = 1&
            End If
            lngSecondsOffset = lngSeconds * CLng(DateDiff("s", #12:00:00 AM#, TimeValue(varTime)) / lngSeconds)
            RoundTime = DateAdd("s", lngSecondsOffset, DateValue(varTime))
        End If
    End If
End Function

 

[Minty]

What does "NOT WORKING" mean?

 

[MajP]

It works for me except for the seconds. The seconds only round down.

Public Sub roundit()
  Dim timeval As Date
  timeval = #12:00:59 PM#
  Debug.Print RoundTime(timeval, 600) & " Time:" & timeval
End Sub

I would expect 12:01:00 here is the result
12:00:00 PM Time:12:00:59 PM

 

[slharman1]

Ok so what I did was put the code in the query field for the recordsource and it works, but I can't seem to format the new date field.
How would I go about this?

 

[slharman1]

Ok, Sorry, I was brain dead, I've got the function working does anyone know how to make it round only up or only down?

 

[MarkK]

Here's a simpler function to round DateTime values to a particular increment...

Function RoundDateToNearest(d1 As Date, RoundTo As Date) As Date
    RoundDateToNearest = CLng(d1 / CDbl(RoundTo)) * RoundTo
End Function

Here's some test code...

Private Sub Test1892734981234()
    Dim t1 As Date
    
    Debug.Print "Saturday", RoundDateToNearest(Date, 7)
    
    t1 = TimeSerial(6, 0, 0)
    Debug.Print "6 hrs", RoundDateToNearest(Now(), t1)
    t1 = TimeSerial(2, 0, 0)
    Debug.Print "2 hrs", RoundDateToNearest(Now(), t1)
    t1 = TimeSerial(1, 30, 0)
    Debug.Print "1.5 hrs", RoundDateToNearest(Time, t1)
    
    t1 = TimeSerial(0, 15, 0)
    Debug.Print "15 mins", RoundDateToNearest(#12:07:29 PM#, t1)
    Debug.Print "15 mins", RoundDateToNearest(#12:07:30 PM#, t1)
    Debug.Print "15 mins", RoundDateToNearest(#12:07:31 PM#, t1)
    
    t1 = TimeSerial(0, 0, 15)
    Debug.Print "15 secs", RoundDateToNearest(Time, t1)
    t1 = TimeSerial(0, 0, 5)
    Debug.Print "5 secs", RoundDateToNearest(Time, t1)
    Debug.Print "Now", Now()
    Debug.Print
    
End Sub

 

[MarkK]

To round up, add half your RoundTo to d1, like...

Function RoundUpToNearestDate(d1 As Date, Optional RoundTo As Date = 1) As Date
      RoundUpToNearestDate = CLng((d1 + RoundTo / 2) / RoundTo) * RoundTo
End Function

 

[slharman1]

Here's a simpler function to round DateTime values to a particular increment...

Function RoundDateToNearest(d1 As Date, RoundTo As Date) As Date
    RoundDateToNearest = CLng(d1 / CDbl(RoundTo)) * RoundTo
End Function

Here's some test code...

Private Sub Test1892734981234()
    Dim t1 As Date
   
    Debug.Print "Saturday", RoundDateToNearest(Date, 7)
   
    t1 = TimeSerial(6, 0, 0)
    Debug.Print "6 hrs", RoundDateToNearest(Now(), t1)
    t1 = TimeSerial(2, 0, 0)
    Debug.Print "2 hrs", RoundDateToNearest(Now(), t1)
    t1 = TimeSerial(1, 30, 0)
    Debug.Print "1.5 hrs", RoundDateToNearest(Time, t1)
   
    t1 = TimeSerial(0, 15, 0)
    Debug.Print "15 mins", RoundDateToNearest(#12:07:29 PM#, t1)
    Debug.Print "15 mins", RoundDateToNearest(#12:07:30 PM#, t1)
    Debug.Print "15 mins", RoundDateToNearest(#12:07:31 PM#, t1)
   
    t1 = TimeSerial(0, 0, 15)
    Debug.Print "15 secs", RoundDateToNearest(Time, t1)
    t1 = TimeSerial(0, 0, 5)
    Debug.Print "5 secs", RoundDateToNearest(Time, t1)
    Debug.Print "Now", Now()
    Debug.Print
   
End Sub

Thanks, I am going to do some testing, how does this handle a date like 1/6/2021 11:59 with rounding up to the nearest 15 minutes?
Will it give me 1/7/2021 12:00?
Will it

 

[slharman1]

To round up, add half your RoundTo to d1, like...

Function RoundUpToNearestDate(d1 As Date, Optional RoundTo As Date = 1) As Date
      RoundUpToNearestDate = CLng((d1 + RoundTo / 2) / RoundTo) * RoundTo
End Function

RoundUpToNearestDate not working, I used the same arguments when test the first function.
Am I doing something wrong?

Getting Runtime error '6'
Overflow

Here's my code:

Private Sub Form_Current()

    If IsNull(txtAdjTimeIn) Then
        Dim T1 As Date
        T1 = TimeSerial(0, 15, 0)
        txtAdjTimeIn = RoundUpToNearestDate(txtTimeIn, T1)
    End If
   
End Sub

 

[MarkK]

I can't get it to fail. What line causes the error?

 

[Gasman]

RoundUpToNearestDate not working, I used the same arguments when test the first function.
Am I doing something wrong?

Getting Runtime error '6'
Overflow

Here's my code:

Private Sub Form_Current()

    If IsNull(txtAdjTimeIn) Then
        Dim T1 As Date
        T1 = TimeSerial(0, 15, 0)
        txtAdjTimeIn = RoundUpToNearestDate(txtTimeIn, T1)
    End If
  
End Sub

Showing your arguments would help?

 

[slharman1]

Showing your arguments would help?

I copied and pasted then realized the code wasn’t complete. Works perfect. Now I have to figure out how to get rid of the seconds in my data so they 5:30 doesn’t become 5:45. Any ideas?
My form that enters the original data captures the date and time, then the form that takes that value and rounds it does what my question above in this post says. Need to get rid of the seconds in the first field. I am thinking I need a format statement in my code - sound right?
Thanks

 

[slharman1]

I can't get it to fail. What line causes the error?

No errors, just a newb being a newb.

 

[MarkK]

Now I have to figure out how to get rid of the seconds in my data so they 5:30 doesn’t become 5:45. Any ideas?

Isn't this why you are rounding the time? Why get rid of the seconds, and then round.

 

[slharman1]

Isn't this why you are rounding the time? Why get rid of the seconds, and then round.

This is for calculating payroll times and if I don't strip the seconds when using your rounding up function - 5:30:01 becomes 5:45:00
But your functions still Rounds 5:30 up to 5:45 - am i doing something wrong?

Public Function RoundUpToNearestDate(d1 As Date, Optional RoundTo As Date = 1) As Date
      'not working
      RoundUpToNearestDate = CLng((d1 + RoundTo / 2) / CDbl(RoundTo)) * RoundTo
End Function

Private Sub Form_Current()
    
    If IsNull(txtAdjTimeIn) And Not IsNull(txtTimeIn) Then
        
        Dim t1 As Date
        Dim t2 As Date
        t2 = DateValue([txtTimeIn]) + TimeSerial(Hour([txtTimeIn]), Minute([txtTimeIn]), 0)
        
        t1 = TimeSerial(0, 15, 0)
        [txtAdjTimeIn] = RoundUpToNearestDate(t2, t1)
        
        'txtAdjTimeIm = roundDate(txtTimeIn, 3)
    End If
    
        If IsNull(txtAdjTimeOut) And Not IsNull(txtTimeOut) Then
        
        Dim t3 As Date
        Dim t4 As Date
        t4 = DateValue([txtTimeOut]) + TimeSerial(Hour([txtTimeOut]), Minute([txtTimeOut]), 0)
        
        t3 = TimeSerial(0, 15, 0)
        [txtAdjTimeOut] = RoundDnToNearestDate(t4, t3)
        
        'txtAdjTimeIm = roundDate(txtTimeIn, 3)
    End If

    
End Sub

I have also created a RoundDnToNearest function to round the time down. So far It seems to work.

 

[slharman1]

I found another solution to my rounding problem.

TimeSerial(Hour([mytime]),(Minute([mytime])\15)*15,0)

Can anyone tell me how to change this to round up?

 

[Minty]

This is for calculating payroll times and if I don't strip the seconds when using your rounding up function - 5:30:01 becomes 5:45:00

As afar as I can see the problem is in your description. You wanted it rounded up
5:30:01 rounded UP to the nearest next 15 minutes is 5:45

I don't think your description matches your actual output requirement. What about 5:31:03 ? or 5:30:59

 

[Gasman]

I used to use increments of 6 minutes?, one tenth of an hour?

 

[slharman1]

As afar as I can see the problem is in your description. You wanted it rounded up
5:30:01 rounded UP to the nearest next 15 minutes is 5:45

I don't think your description matches your actual output requirement. What about 5:31:03 ? or 5:30:59

The problem is this:
I do not want to round up if the employee punches in at 5:30:01, that is still considered punching in at 5:30, it is only when they punch in at 5:31:00 or greater that I want to round up.

 

[slharman1]

I used to use increments of 6 minutes?, one tenth of an hour?

I am not sure what you are saying here Gasman, If my employee is late by 1 minute then they are considered late.
so...
5:30:01 still needs to round to 5:30 but 5:31:00 needs to round up to 5:45:00

The similar situation applies when they are punching out.