VBA help to count Daytime,Nighttime and Summary

[tseklee]

Hello, i am using Mr Rosenkrantz's VBA code to calculate daytime, nighttime and the summary in an excel sheet. Here is the referenced link:

TIME REGISTRATION | Calculate multiple time shift hours

You can use VBA for time registration. Building a procedure that calculates the number of hours a person worked is not difficult. How does it work?

www.excelacademy.nl

I have made some changes to the code to count as nighttime from 00:00 to 05:00 since i don't want it to count as nighttime from 00:00 to 06:00 and namely i changed all 0.25 to 0.2083333333333.
I am having trouble though to make the code to actually count from 21:00 till 05:00. Here is the code that Mr Rosenkrantz created without any changes.

VBA - Timesheet with Day and Night shift hours

'''
'''------------------------------------------------------------------------------------------------
''' Code written and tested by:
''' MR Rosenkrantz
''' Spreadsheet Solutions
''' http://www.spreadsheetsolutions.nl
''' mark@spreadsheetsolutions.nl
''' Current version: 1.00 - dd 26/02/2020
'''------------------------------------------------------------------------------------------------
'''
Option Explicit
Public Sub CALCULATE_TOTALS()
    'Variables for ThisWorkbook -------------------------------------------------------------------
    Dim strTS_APP As String      'ThisWorkbook as String
    Dim wbTS_APP As Workbook     'ThisWorkbook as Workbook
    'Variables on worksheet Data ------------------------------------------------------------------
    Dim wsDATA As Worksheet      'Worksheet Data as worksheet object
    Dim cRecDATA As Integer      'Current record on worksheet DATA
    Dim lRecDATA As Integer      'Last record on worksheet DATA
    
    'Reference to Workbook and Worksheets
    strTS_APP = ThisWorkbook.Name
    Set wbTS_APP = Workbooks(strTS_APP)
    Set wsDATA = wbTS_APP.Worksheets("Data")

'-- Totals ----------------------------------------------------------------------------------------
    With wsDATA
        'Determine the Last record on the worksheet
        lRecDATA = .Cells(1048576, 2).End(xlUp).Row

        'Loop through all records from the Data Table
        For cRecDATA = 10 To lRecDATA

                'Case 01 - Start before 00:00 and End before 06:00
                If .Cells(cRecDATA, 8) > .Cells(cRecDATA, 9) And _
                   .Cells(cRecDATA, 9) <= 0.25 Then
                    'Part 01 - Hours before 00:00
                    .Cells(cRecDATA, 11) = 1 - .Cells(cRecDATA, 8)
                    'Part 02 - Hours between 00:00 and 06:00
                    .Cells(cRecDATA, 12) = .Cells(cRecDATA, 9)
                End If

                'Case 02 - Start before 00:00 and End after 06:00
                If .Cells(cRecDATA, 8) > .Cells(cRecDATA, 9) And _
                   .Cells(cRecDATA, 9) > 0.25 Then
                    'Part 01 - Hours before 00:00
                    .Cells(cRecDATA, 11) = 1 - .Cells(cRecDATA, 8)
                    'Part 02 - Hours between 00:00 and 06:00 (Always 6)
                    .Cells(cRecDATA, 12) = 0.25
                    'Part 03 - Hours after 06:00
                    .Cells(cRecDATA, 11) = .Cells(cRecDATA, 11) + (.Cells(cRecDATA, 9) - 0.25)
                End If

                'Case 03 - Start between 00:00 and 06:00 and End before 06:00
                If .Cells(cRecDATA, 8) >= 0 And _
                   .Cells(cRecDATA, 8) < 0.25 And _
                   .Cells(cRecDATA, 9) <= 0.25 Then
                    'Part 01 - Hours between 00:00 and 06:00
                    .Cells(cRecDATA, 12) = .Cells(cRecDATA, 9) - .Cells(cRecDATA, 8)
                End If

                'Case 04 - Start between 00:00 and 06:00 and End after 06:00
                If .Cells(cRecDATA, 8) >= 0 And _
                   .Cells(cRecDATA, 8) < 0.25 And _
                   .Cells(cRecDATA, 9) > 0.25 Then
                    'Part 01 - Hours between 00:00 and 06:00
                    .Cells(cRecDATA, 12) = 0.25 - .Cells(cRecDATA, 8)
                    'Part 02 - Hours after 06:00
                    .Cells(cRecDATA, 11) = .Cells(cRecDATA, 9) - 0.25
                End If

                'Case 05 - Start after 06:00 and End after 06:00
                If .Cells(cRecDATA, 8) < .Cells(cRecDATA, 9) And _
                   .Cells(cRecDATA, 8) > 0.25 Then
                    'Part 01 - Hours after 06:00
                    .Cells(cRecDATA, 11) = .Cells(cRecDATA, 9) - .Cells(cRecDATA, 8)
                End If

                'Add to Grand Total
                .Cells(cRecDATA, 13) = .Cells(cRecDATA, 11) + .Cells(cRecDATA, 12) - .Cells(cRecDATA, 10)

        Next cRecDATA
    .Cells(6, 11).Select
    End With
End Sub

Can someone help please?

 

[NoSparks]

Works for me.
Make sure you changed all 11 locations of 0.25

 

[tseklee]

Works for me.
Make sure you changed all 11 locations of 0.25

I don't think i have made a mistake actually. The 0.25 corresponds to the time 06:00 and the number 0.2083333333333 to the time 05:00, what i need it to do though is to change also the starting count time from 00:00 to 21:00. I know that the number for 21:00 is 0.875 but when i change the number 1 which corresponds to the time 00:00 to 0.875 then it will show error.

 

[Alex Blakenburg]

Any reason this needs to be code and not just a formula ?
Also please post at a bare minimum an image of your data that contain the row and column references. An XL2BB of the data would be even better.

20240810 VBA Time in Night shift tseklee.xlsm
	A	B	C	D	E	F	G	H	I	J
1	Item	Start	End	Day Time	Night Time	Total	Night		From	To
2	1	20:00	3:00		6:00				21:00	5:00
3	2	20:00	23:59		2:59
4	3	1:00	6:00		4:00
5	4	1:00	3:00		2:00
6
Sheet1

Cell Formulas
Range	Formula
E2:E5	E2	=IF(B2>C2,1-MAX(B2,$I$2)+MIN(C2,$J$2), IF(C2>$I$2,C2-MAX(B2,$I$2), IF(B2<$J$2,MIN(C2,$J$2)-B2,0)))

 

[NoSparks]

Sorry, misinterpreted the original post.

You can't change the 1 as it refers to midnight not the start of the night shift.
It just conveniently happens that the night shift starts at midnight in Mr Rosenkrantz's example
and he states

The possibility to start a shift before midnight and end a shift before or after 06:00, leads to a total of three calculations that may have to be made for each of the five situations mentioned

You need to use 1 for midnight when calculating the time UNTIL midnight.
ie: 1 - 21:00 = 3:00

 

[tseklee]

Any reason this needs to be code and not just a formula ?

No, just that i need to have separate columns for Daytime/Nighttime and the example fit my needs perfectly. Can you please edit your formula to not make use of columns I and J. In my sheet i can't spare two extra columns, it is really full.

 

[tseklee]

Sorry, misinterpreted the original post.

You can't change the 1 as it refers to midnight not the start of the night shift.
It just conveniently happens that the night shift starts at midnight in Mr Rosenkrantz's example
and he states


You need to use 1 for midnight when calculating the time UNTIL midnight.
ie: 1 - 21:00 = 3:00

Do you know how to do this in VBA?

 

[Alex Blakenburg]

No, just that i need to have separate columns for Daytime/Nighttime and the example fit my needs perfectly. Can you please edit your formula to not make use of columns I and J. In my sheet i can't spare two extra columns, it is really full.

If you didn't want it on that sheet I would put it on a parameters sheet rather than hard coding it into the formula.
If you really want to hard code it try this:

=IF(B2>C2,1-MAX(B2,21/24)+MIN(C2,5/24),
    IF(C2>21/24,C2-MAX(B2,21/24),
    IF(B2<5/24,MIN(C2,5/24)-B2,0)))

 

[tseklee]

If you didn't want it on that sheet I would put it on a parameters sheet rather than hard coding it into the formula.
If you really want to hard code it try this:

=IF(B2>C2,1-MAX(B2,21/24)+MIN(C2,5/24),
    IF(C2>21/24,C2-MAX(B2,21/24),
    IF(B2<5/24,MIN(C2,5/24)-B2,0)))

The formula will return 5 if the cells are left empty.

 

[NoSparks]

Here's a VBA macro you can try.
It's written to run against the sheet downloaded from the site you linked to.
Format the Day, Night, Total area as number with 2 decimal places to show hours as hours instead of times.
If required, can supply my test file.

Option Explicit


Sub Calc_Totals()

    Const DayStart As Double = #5:00:00 AM#
    Const NightStart As Double = #9:00:00 PM#
    
    Dim WorkStart As Double, WorkEnd As Double
    Dim DayHours As Double, NightHours As Double, BreakHours As Double
    
    Dim lastrow As Long
    Dim rng As Range, cel As Range
    
    With Sheets("DATA")
        lastrow = .Cells(.Rows.Count, 2).End(xlUp).Row
        ' clear existing results
        .Range("K10:M" & lastrow).ClearContents
        
        ' set the range to work with
        Set rng = .Range("H10:H" & lastrow)
        
        For Each cel In rng
            WorkStart = cel
            WorkEnd = cel.Offset(, 1)
            BreakHours = cel.Offset(, 2)
            
            ' start within dayshift
            If WorkStart >= DayStart And WorkStart < NightStart Then
                    If WorkEnd > WorkStart And WorkEnd <= NightStart Then
                        DayHours = WorkEnd - WorkStart
                    ElseIf WorkEnd > NightStart And WorkEnd < 1 Then
                        DayHours = NightStart - WorkStart
                        NightHours = WorkEnd - NightStart
                    ElseIf WorkEnd <= DayStart Then
                        DayHours = NightStart - WorkStart
                        NightHours = 1 - NightStart + WorkEnd
                    ElseIf WorkEnd > DayStart And WorkEnd <= WorkStart Then
                        DayHours = NightStart - WorkStart + WorkEnd - DayStart
                        NightHours = 1 - NightStart + DayStart
                    End If
            End If
            
            'within nightshift before midnight
            If WorkStart >= NightStart And WorkStart < 1 Then
                    If WorkEnd > WorkStart And WorkEnd <= 1 Then
                        NightHours = WorkEnd - WorkStart
                    ElseIf WorkEnd <= DayStart Then
                        NightHours = 1 - WorkStart + WorkEnd
                    ElseIf WorkEnd > DayStart Then
                        DayHours = WorkEnd - DayStart
                        NightHours = 1 - WorkStart + DayStart
                    End If
            End If
            
            'within nightshift after midnight
            If WorkStart <= DayStart Then
                    If WorkEnd > WorkStart And WorkEnd <= DayStart Then
                        NightHours = WorkEnd - WorkStart
                    ElseIf WorkEnd > DayStart And WorkEnd <= NightStart Then
                        DayHours = WorkEnd - DayStart
                        NightHours = DayStart - WorkStart
                    ElseIf WorkEnd > NightStart And WorkEnd <= 1 Then
                        DayHours = NightStart - DayStart
                        NightHours = DayStart - WorkStart + 1 - WorkEnd
                    ElseIf WorkEnd <= WorkStart Then
                        DayHours = NightStart - DayStart
                        NightHours = DayStart - WorkStart + 1 - NightStart + WorkEnd
                    End If
            End If
            
            'write calcs to sheet
            If Not IsEmpty(cel) And Not IsEmpty(cel.Offset(, 1)) Then
                .Cells(cel.Row, "K") = DayHours * 24
                .Cells(cel.Row, "L") = NightHours * 24
                .Cells(cel.Row, "M") = (DayHours + NightHours - BreakHours) * 24
            End If
            
            'reset in prep for next row
            DayHours = 0
            NightHours = 0
            BreakHours = 0
            
        Next cel
    End With
End Sub