VBA help to count Daytime,Nighttime and Summary

tseklee

New Member
Joined
Nov 4, 2023
Messages
20
Office Version
  1. 2007
Platform
  1. Windows
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:

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

VBA Code:
'''
'''------------------------------------------------------------------------------------------------
''' 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?
 

Excel Facts

Pivot Table Drill Down
Double-click any number in a pivot table to create a new report showing all detail rows that make up that number
I can't get the correct results. Please check the picture.
 

Attachments

  • New Bitmap Image.gif
    New Bitmap Image.gif
    92.7 KB · Views: 14
Upvote 0
No. These are the results i am getting now.
 

Attachments

  • New Bitmap Image2.gif
    New Bitmap Image2.gif
    20.5 KB · Views: 10
Upvote 0
Show us what you are expecting ? What are you showing is consistent with my understanding of what you have described as being the requirement.
PS: If you are going to use pictures please make sure you include the Row and Column references (and for VBA the sheet name as well)
 
Upvote 0
Show us what you are expecting ? What are you showing is consistent with my understanding of what you have described as being the requirement.
PS: If you are going to use pictures please make sure you include the Row and Column references (and for VBA the sheet name as well)
Ok, i have just typed them right next to the results i am getting.
So, i want it to count as nighttime from 21:00 to 05:00. The other columns are pretty much self explanatory.
This is also the same columns and lanes using Mr Rosenkrantz's file, exactly as you written it to be used.
 

Attachments

  • New Bitmap Image.gif
    New Bitmap Image.gif
    28 KB · Views: 13
Upvote 0
I can't get the correct results. Please check the picture.
just go into the code and remove the * 24 from each of the 3 lines near the end to be like this
VBA Code:
            'write calcs to sheet
            If Not IsEmpty(cel) And Not IsEmpty(cel.Offset(, 1)) Then
                .Cells(cel.Row, "K") = DayHours
                .Cells(cel.Row, "L") = NightHours
                .Cells(cel.Row, "M") = (DayHours + NightHours - BreakHours)
            End If
 
Upvote 0
Let me know if you are just not interested in using a formula, although in your scenario I am not sure why you would want VBA.
Based on your last example that is exactly what the formula I gave you produces, so I am not sure why you said it is not working.

20240810 VBA Time in Night shift tseklee.xlsm
ABCDEF
1ItemStartEndDay TimeNightTotal
2123:595:590:595:016:00
3223:596:011:015:016:02
430:015:590:594:595:58
540:016:011:014:596:00
66:0112:016:000:006:00
76:000:0015:003:0018:00
Sheet1 Diff Example
Cell Formulas
RangeFormula
D2:D7D2=F2-E2
E2:E7E2=IF(AND(B2<>"",C2<>""), 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))),"")
F2:F7F2=IF(C2<B2,C2+1-B2,C2-B2)
 
Upvote 0
Thank you now it seems to be working fine.
 
Upvote 0
I don't know the difference between using a VBA script and a formula. Yes, i am so newbie. For the moment though i am really happy to give both ways some testing.
Can you please edit the Total/Summary column(F) so that it takes into account also the break? Also for some reason i am getting false results.
Also the Daytime column can it output 0 or be blank instead of returning "Value" when no entry is found?
 

Attachments

  • New Bitmap Image.gif
    New Bitmap Image.gif
    18.5 KB · Views: 13
Upvote 0
I am sorry, i have tested again your formula on a new sheet and it seems to return correct nighttime results. But on another sheet where i store my data the results are wrong, exactly like the picture i posted. Now i'm puzzled...
 
Upvote 0

Forum statistics

Threads
1,226,536
Messages
6,191,629
Members
453,668
Latest member
Stephen_Santos

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top