Calculate total clocked In minutes in a given hour

Hi,

Rheck the report sheet in the attached workbook: TimeDifference.xlsm
Note: report is created by button click on first sheet, the chart in the report is added manually
You can adapt the time range to check in the code, e.g. 0:00 - 24:00 or, like implemented, 9:00 - 24:00 or whatever you need

Code:

Option Explicit

Private Sub CommandButton1_Click()
    Dim aDataIn, aDataOut, aHeads()
    Dim dTimeStart As Date, dTimeEnd As Date
    Dim blnFullHour As Boolean
    Dim strWsname$
    Dim i&, j&, k&, n&, m&
    
    On Error GoTo CommandButton1_Click_ErrorHandler
'    Application.ScreenUpdating = False

    aDataIn = ActiveSheet.UsedRange.Value
    
    'get number of days
    For i = LBound(aDataIn, 2) To UBound(aDataIn, 2)
        If IsDate(aDataIn(1, i)) Then
            j = j + 1
            ReDim Preserve aHeads(1 To j)
            aHeads(j) = CDate(aDataIn(1, i))
        End If
    Next i
    
    'set size of output array
'    ReDim aDataOut(1 To 25, 1 To j + 2)     'use this to start at 0:00
    ReDim aDataOut(1 To 16, 1 To j + 2)     'use this to start at 9:00
    
    'set headings
    j = 3
    For i = LBound(aHeads) To UBound(aHeads)
        aDataOut(1, j) = aHeads(i)
        j = j + 1
    Next i
    Erase aHeads
    
    'set times
'    j = 0                                   'use this to start at 0:00
    j = 90000                               'use this to start at 9:00
    For i = LBound(aDataOut, 1) + 1 To UBound(aDataOut, 1)
        aDataOut(i, 1) = TimeValue(Format(CStr(j), "#0:00:00"))
        aDataOut(i, 2) = TimeValue(Format(CStr(j + 5959), "#0:00:00"))
        j = j + 10000
    Next i
    
    'calculation
    m = 3
    For i = LBound(aDataIn, 2) To UBound(aDataIn, 2)
        If IsDate(aDataIn(1, i)) Then
            j = i + 1
            For k = LBound(aDataIn, 1) + 1 To UBound(aDataIn, 1)
                blnFullHour = False
                If aDataIn(k, j) = 0 Then Exit For
                dTimeStart = TimeValue(Format(CStr(aDataIn(k, j)), "#0:00"))
                dTimeEnd = TimeValue(Format(CStr(aDataIn(k, j + 1)), "#0:00"))
                For n = LBound(aDataOut, 1) + 1 To UBound(aDataOut, 1)
                    If dTimeStart >= aDataOut(n, 1) And dTimeStart < aDataOut(n, 2) Then
                        blnFullHour = True
                        aDataOut(n, m) = aDataOut(n, m) + DateDiff("n", dTimeStart, aDataOut(n, 2) + TimeSerial(0, 0, 1))
                    
                    ElseIf dTimeEnd > aDataOut(n, 1) And dTimeEnd <= aDataOut(n, 2) + TimeSerial(0, 0, 1) Then
                        blnFullHour = False
                        aDataOut(n, m) = aDataOut(n, m) + DateDiff("n", aDataOut(n, 1) + TimeSerial(0, 0, 1), dTimeEnd)
                        
                    ElseIf blnFullHour Then
                        aDataOut(n, m) = aDataOut(n, m) + 60

                    End If
                Next n
            Next k
            m = m + 1
        End If
    Next i
    
    'write to sheet
    With ThisWorkbook
        i = 0
        strWsname = "Result"
        Do While WsExists(strWsname, ThisWorkbook)
            strWsname = Left$(strWsname, 6) & "_" & i
            i = i + 1
        Loop
        With .Worksheets.Add(After:=.Worksheets(.Worksheets.Count))
            .Name = strWsname
            .Cells(1, 1).Resize(UBound(aDataOut, 1), UBound(aDataOut, 2)).Value = aDataOut
            .Range("A:B").NumberFormat = "hh:mm:ss"
            .Cells.EntireColumn.AutoFit
        End With
    End With

CommandButton1_Click_Proc_Exit:
    Application.ScreenUpdating = True
    Exit Sub
CommandButton1_Click_ErrorHandler:
    MsgBox "Error: " & Err.Number & " (" & Err.Description & ") in Sub 'CommandButton1_Click' of VBA Document 'Sheet1'.", vbOKOnly + vbCritical, "Error"
    Resume CommandButton1_Click_Proc_Exit
End Sub

Function WsExists(ByVal wsName As String, Optional xlWb As Excel.Workbook) As Boolean
    On Error Resume Next
    Dim xlWs As Worksheet
    If xlWb Is Nothing Then Set xlWb = ActiveWorkbook
    Set xlWs = xlWb.Worksheets(wsName)
    WsExists = (Err.Number = 0)
    Set xlWs = Nothing
End Function

Hi,

changes as required, also solved a bug where a person logged in and out in the same hour. Note, if the start time is smaller or equal the end time "#Error" will be inserted instead of the day name in the header and the corresponding date will not be calculated till the end: TimeDifference 2.0.xlsm
Good night
Code:

Option Explicit

Private Sub CommandButton1_Click()
    Dim aDataIn, aDataOut
    Dim dTimeStart As Date, dTimeEnd As Date
    Dim blnFullHour As Boolean
    Dim i&, j&, k&, n&, m&
    
    On Error GoTo CommandButton1_Click_ErrorHandler
    Application.ScreenUpdating = False

    With ActiveSheet
        aDataIn = .Range(.Cells(1, 3), .Cells(.UsedRange.Row + .UsedRange.Rows.Count - 1, .UsedRange.Column + .UsedRange.Columns.Count - 1)).Value
    End With
    
    'set size of output array
    ReDim aDataOut(1 To 16, 1 To UBound(aDataIn, 2) + 2)
    
    'set headings
    For i = LBound(aDataIn, 2) To UBound(aDataIn, 2)
        If IsDate(aDataIn(1, i)) Then
            aDataOut(1, i + 2) = CDate(aDataIn(1, i))
            aDataOut(1, i + 3) = Format(CDate(aDataIn(1, i)), "ddd")
        End If
    Next i
    
    'set times
    j = 90000
    For i = LBound(aDataOut, 1) + 1 To UBound(aDataOut, 1)
        aDataOut(i, 1) = TimeValue(Format(CStr(j), "#0:00:00"))
        aDataOut(i, 2) = TimeValue(Format(CStr(j + 5959), "#0:00:00"))
        j = j + 10000
    Next i
    
    'calculation
    For i = LBound(aDataIn, 2) To UBound(aDataIn, 2)
        If IsDate(aDataIn(1, i)) Then
            j = i + 1: m = i + 3
            For k = LBound(aDataIn, 1) + 1 To UBound(aDataIn, 1)
                blnFullHour = False
                If aDataIn(k, j) = 0 Then Exit For
                dTimeStart = TimeValue(Format(CStr(aDataIn(k, j)), "#0:00"))
                dTimeEnd = TimeValue(Format(CStr(aDataIn(k, j + 1)), "#0:00"))
                If dTimeEnd <= dTimeStart Then aDataOut(1, m) = "#Error": Exit For
                For n = LBound(aDataOut, 1) + 1 To UBound(aDataOut, 1)
                    If dTimeStart >= aDataOut(n, 1) And dTimeStart < aDataOut(n, 2) And dTimeEnd > aDataOut(n, 1) And dTimeEnd <= aDataOut(n, 2) + TimeSerial(0, 0, 1) Then
                        aDataOut(n, m) = aDataOut(n, m) + DateDiff("n", dTimeStart, dTimeEnd)
                        Exit For
                        
                    ElseIf dTimeStart >= aDataOut(n, 1) And dTimeStart < aDataOut(n, 2) Then
                        blnFullHour = True
                        aDataOut(n, m) = aDataOut(n, m) + DateDiff("n", dTimeStart, aDataOut(n, 2) + TimeSerial(0, 0, 1))
                    
                    ElseIf dTimeEnd > aDataOut(n, 1) And dTimeEnd <= aDataOut(n, 2) + TimeSerial(0, 0, 1) Then
                        aDataOut(n, m) = aDataOut(n, m) + DateDiff("n", aDataOut(n, 1) + TimeSerial(0, 0, 1), dTimeEnd)
                        Exit For
                        
                    ElseIf blnFullHour Then
                        aDataOut(n, m) = aDataOut(n, m) + 60

                    End If
                Next n
            Next k
        End If
    Next i
    
    'write to sheet
    With ActiveSheet
        i = .UsedRange.Row + .UsedRange.Rows.Count + 2
        With .Cells(i, 1).Resize(UBound(aDataOut, 1), UBound(aDataOut, 2))
            .Value = aDataOut
            .Rows(1).NumberFormat = "dd.mm.yyyy"
            .Columns("A:B").NumberFormat = "hh:mm:ss"
            .Cells.EntireColumn.AutoFit
        End With
    End With

CommandButton1_Click_Proc_Exit:
    Application.ScreenUpdating = True
    Exit Sub
CommandButton1_Click_ErrorHandler:
    MsgBox "Error: " & Err.Number & " (" & Err.Description & ") in Sub 'CommandButton1_Click' of VBA Document 'Sheet1'.", vbOKOnly + vbCritical, "Error"
    Resume CommandButton1_Click_Proc_Exit
End Sub

Function WsExists(ByVal wsName As String, Optional xlWb As Excel.Workbook) As Boolean
    On Error Resume Next
    Dim xlWs As Worksheet
    If xlWb Is Nothing Then Set xlWb = ActiveWorkbook
    Set xlWs = xlWb.Worksheets(wsName)
    WsExists = (Err.Number = 0)
    Set xlWs = Nothing
End Function

Hi,

1. How to find out where it ends?
2. done
3 + 4. done with formula
5. It's not a bug, it's a feature ! ... done (hardcoded)

TimeDifference 2.1.xlsm

Hello:

The code works but still need little tweaking.

1. Instead of Range starting in J609, please start at I609.( so now you have time range in Cell I609:J621)
2. Start # of Minutes in N609 instead of M609 and so on..
Leave column K,L and M blank since i am using those columns to add cumalative for all days.
3. There seems to be bug in minute calc....if you see your attached sheet,
Calculated minutes in column M,Q row 609 onward is wrong.
Please check and let me know if any questions.
4. Date and Day can start in cell
O608 and P608
S608 and T608 and onwards
5. Your question was where does data ends:
Data will be O48:EG78
Data for a particular date will end when cell in employee column is blank.

Once again, thank you so much for your great help.

PLEASE REFER TO EXCEL FILE ATTACHED IN NEXT REPLY.

Riz Momin

Hi,

1. + 2. + 4. Output range as required
3. Calculation bug found and fixed
4. Input range is still hard-coded. This means if you change the location of the input strange things will happen. There is no fast way to find out the entire data range, mainly because of the blank columns between the data and because there is data below the input.


try TimeDifference 2.2.xlsm

code

Option Explicit

Private Sub CommandButton1_Click()
    Dim aDataIn, aDataOut
    Dim dTimeStart As Date, dTimeEnd As Date
    Dim blnFullHour As Boolean
    Dim i&, j&, k&, n&, m&
    
    On Error GoTo CommandButton1_Click_ErrorHandler
    Application.ScreenUpdating = False

    With ActiveSheet    'data to array
        aDataIn = .Cells(46, 15).Resize(33, 124).Value
    End With
    
    'set size of output array
    ReDim aDataOut(1 To 14, 1 To UBound(aDataIn, 2) + 6)
    
    'set headings
    For i = LBound(aDataIn, 2) To UBound(aDataIn, 2)
        If IsDate(aDataIn(1, i)) Then
            aDataOut(1, i + 6) = CDate(aDataIn(1, i))
            aDataOut(1, i + 7) = Format(CDate(aDataIn(1, i)), "ddd")
        End If
    Next i
    
    'set times
    j = 100000
    For i = LBound(aDataOut, 1) + 1 To UBound(aDataOut, 1)
        aDataOut(i, 1) = TimeValue(Format(CStr(j), "#0:00:00"))
        aDataOut(i, 2) = TimeValue(Format(CStr(j + 5959), "#0:00:00"))
        j = j + 10000
    Next i
    
    'calculation
    For i = LBound(aDataIn, 2) To UBound(aDataIn, 2)
        If IsDate(aDataIn(1, i)) Then
            j = i + 1: m = i + 7
            For k = LBound(aDataIn, 1) + 1 To UBound(aDataIn, 1)
                blnFullHour = False
                If aDataIn(k, j) = 0 Then Exit For
                dTimeStart = TimeValue(Format(CStr(aDataIn(k, j)), "#0:00"))
                dTimeEnd = TimeValue(Format(CStr(aDataIn(k, j + 1)), "#0:00"))
                If dTimeEnd <= dTimeStart Then aDataOut(1, m) = "#Error": Exit For
                For n = LBound(aDataOut, 1) + 1 To UBound(aDataOut, 1)
                    If DateDiff("n", aDataOut(n, 1), dTimeStart) >= 0 And DateDiff("n", aDataOut(n, 2), dTimeStart) < 0 _
                        And DateDiff("n", aDataOut(n, 1), dTimeEnd) > 0 And DateDiff("n", aDataOut(n, 2) + TimeSerial(0, 0, 1), dTimeEnd) <= 0 Then

                        aDataOut(n, m) = aDataOut(n, m) + DateDiff("n", dTimeStart, dTimeEnd)
                        Exit For
                        
                    ElseIf DateDiff("n", aDataOut(n, 1), dTimeStart) >= 0 And DateDiff("n", aDataOut(n, 2), dTimeStart) < 0 Then
                        blnFullHour = True
                        aDataOut(n, m) = aDataOut(n, m) + DateDiff("n", dTimeStart, aDataOut(n, 2) + TimeSerial(0, 0, 1))
                    
                    ElseIf DateDiff("n", aDataOut(n, 1), dTimeEnd) > 0 And DateDiff("n", aDataOut(n, 2) + TimeSerial(0, 0, 1), dTimeEnd) <= 0 Then
                        aDataOut(n, m) = aDataOut(n, m) + DateDiff("n", aDataOut(n, 1) + TimeSerial(0, 0, 1), dTimeEnd)
                        Exit For
                        
                    ElseIf blnFullHour Then
                        aDataOut(n, m) = aDataOut(n, m) + 60

                    End If
                    aDataOut(n, m + 2) = "=IF(RC[-2]*0.125=0,"""",RC[-2]*0.125)"
                Next n
                aDataOut(n, m + 2) = "=IF(RC[-2]*0.125=0,"""",RC[-2]*0.125)"
            Next k
        End If
    Next i
    
    'write to sheet
    With ActiveSheet
        With .Cells(608, 9).Resize(UBound(aDataOut, 1), UBound(aDataOut, 2))
            .Formula = aDataOut
            .Rows(1).NumberFormat = "dd.mm.yyyy"
            .Columns("A:B").NumberFormat = "hh:mm:ss"
            .Cells.EntireColumn.AutoFit
        End With
    End With

CommandButton1_Click_Proc_Exit:
    Application.ScreenUpdating = True
    Exit Sub
CommandButton1_Click_ErrorHandler:
    MsgBox "Error: " & Err.Number & " (" & Err.Description & ") in Sub 'CommandButton1_Click' of VBA Document 'Sheet1' in line " & Erl & ".", vbOKOnly + vbCritical, "Error"
    Resume CommandButton1_Click_Proc_Exit
End Sub

Function WsExists(ByVal wsName As String, Optional xlWb As Excel.Workbook) As Boolean
    On Error Resume Next
    Dim xlWs As Worksheet
    If xlWb Is Nothing Then Set xlWb = ActiveWorkbook
    Set xlWs = xlWb.Worksheets(wsName)
    WsExists = (Err.Number = 0)
    Set xlWs = Nothing
End Function

Hi,

1. Existing data and new calculated will be merged in the paste area according to the following rule: Data will only be kept if the calculation array, holding all values/headers/times is empty for this specific cell.
2. Applied accounting numberformat ("_($* #,##0.00_);_($* (#,##0.00);_($* ""-""??_);_(@_)") with 2 decimals. If you want to change this record a macro where you assign a numberformat to a cell and replace the string with the one I implemented.
3. removed from code
4. Changed to "mm/dd/yyyy" using numberformat "mm\/dd\/yyyy"

TimeDifference 2.3.xlsm

Code in attachment, will post into forum when final.