VBA Code to find overlapping time

[muhleebbin]

Could someone assist me in producing some VBA code that could find overlapping time on a timesheet workbook my software produces?

Current VBA gets me to this point:

SUBMITTED TIME REPORT -- 10262020 - Mon - 11012020 - Sun.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T
1	Date	Job		Time In	Time Out	Cost Code		Hours	Earn Code								Phase			sort
2	1 - Test																		Subtotal Hours : 44.25	1
3	10/26/2020	958 - Test	1 - Test	8:00 AM	10:00 AM	1503 - Gaging & rodding	-	2	REG	$0.00	Test	-	-	Test	-	-	101 - Exterior Entry Way	Pending	11/03/2020 4:52 pm UTC	1.1
4	10/26/2020	958 - Test	1 - Test	10:00 AM	4:00 PM	200 - Floor - Tile	-	6	REG	$0.00	Test	-	-	Test	-	-	101 - Exterior Entry Way	Pending	11/03/2020 4:53 pm UTC	1.1
5	10/26/2020	958 - Test	1 - Test	10:00 AM	4:00 PM	200 - Floor - Tile	-	6	REG	$0.00	Test	-	-	Test	-	-	101 - Exterior Entry Way	Pending	11/03/2020 4:54 pm UTC	1.1
6	10/27/2020	958 - Test	1 - Test	8:30 AM	5:00 PM	200 - Floor - Tile	-	8.5	REG	$0.00	Test	-	-	Test	-	-	101 - Exterior Entry Way	Pending	11/03/2020 4:56 pm UTC	1.1
7	10/28/2020	958 - Test	1 - Test	8:00 AM	11:30 AM	200 - Floor - Tile	-	3.5	REG	$0.00	Test	-	-	Test	-	-	101 - Exterior Entry Way	Pending	11/03/2020 4:57 pm UTC	1.1
8	10/28/2020	632 - Test2	1 - Test	11:30 AM	3:15 PM	220 - Backsplash - Tile	-	3.75	REG	$0.00	Test	-	-	Test	-	-	109 - Kitchen	Pending	11/03/2020 5:03 pm UTC	1.1
9	10/29/2020	632 - Test2	1 - Test	7:00 AM	2:30 PM	220 - Backsplash - Tile	-	7.5	REG	$0.00	Test	-	-	Test	-	-	109 - Kitchen	Pending	11/03/2020 5:05 pm UTC	1.1
10	10/30/2020	632 - Test2	1 - Test	7:30 AM	2:30 PM	220 - Backsplash - Tile	-	7	REG	$0.00	Test	-	-	Test	-	-	108 - Media Room Kitchen	Pending	11/03/2020 5:07 pm UTC	1.1
11								44.25
12								4.25
13	3 - Test 3																		Subtotal Hours : 40	3
14	10/26/2020	957 - Test4	3 - Test 3	7:00 AM	3:00 PM	1513 - Pedestal set Pavers	-	8	REG	$0.00	Test	-	-	Test6	-	-	105 - Deck Pavers	Pending	10/28/2020 12:17 am UTC	3.1
15	10/27/2020	957 - Test4	3 - Test 3	7:00 AM	3:00 PM	1513 - Pedestal set Pavers	-	8	REG	$0.00	Test	-	-	Test6	-	-	105 - Deck Pavers	Pending	10/28/2020 12:18 am UTC	3.1
16	10/28/2020	957 - Test4	3 - Test 3	7:00 AM	3:00 PM	1513 - Pedestal set Pavers	-	8	REG	$0.00	Test	-	-	Test6	-	-	105 - Deck Pavers	Pending	10/30/2020 1:43 pm UTC	3.1
17	10/29/2020	957 - Test4	3 - Test 3	7:00 AM	3:00 PM	1513 - Pedestal set Pavers	-	8	REG	$0.00	Test	-	-	Test6	-	-	105 - Deck Pavers	Pending	10/30/2020 1:44 pm UTC	3.1
18	10/30/2020	957 - Test4	3 - Test 3	7:00 AM	3:00 PM	1513 - Pedestal set Pavers	-	8	REG	$0.00	Test	-	-	Test6	-	-	105 - Deck Pavers	Pending	10/31/2020 2:19 pm UTC	3.1
19								40
20								0
Sheet1

Cell Formulas
Range	Formula
H11	H11	=SUM($H$3:$H$10)
H12	H12	=IF(H11>40,IF((H11-SUMIF($F$3:$F$10,"*PTO*",$H$3:$H$10)-SUMIF($F$3:$F$10,"*Holiday*",$H$3:$H$10)>40),H11-SUMIF($F$3:$F$10,"*PTO*",$H$3:$H$10)-SUMIF($F$3:$F$10,"*Holiday*",$H$3:$H$10)-40,0),0)
H19	H19	=SUM($H$14:$H$18)
H20	H20	=IF(H19>40,IF((H19-SUMIF($F$14:$F$18,"*PTO*",$H$14:$H$18)-SUMIF($F$14:$F$18,"*Holiday*",$H$14:$H$18)>40),H19-SUMIF($F$14:$F$18,"*PTO*",$H$14:$H$18)-SUMIF($F$14:$F$18,"*Holiday*",$H$14:$H$18)-40,0),0)

Cells with Conditional Formatting
Cell	Condition		Cell Format	Stop If True
C14:C18	Cell Value	contains "1 - General Costs"	text	NO
D14	Cell Value	contains "1 - General Costs"	text	NO
F1,E376:E1048576,F375,F359:F370,E2:E358	Cell Value	contains "1 - General Costs"	text	NO

But as you can see on 1 - Test for 10/26/20 there is a duplicate entry. Could VBA code find overlapping time over each individual date for each employee? This sample data above only shows two employees but there are over 40 employees in the real data set.

 

[pbornemeier]

This code only processes selected rows. You will have to work out a better way to populate aryTimes with the data you want to process. There is 360 minutes of overlap in post #1 first data block.

Option Explicit

Sub OverlappingTimes()
    'Select the rows of your report to be processed
    Dim aryTimes() As Variant '(1 to 2, 1 to n)
                            '1 holds start DTS, 2 holds finish DTS
    Dim rngCell As Range
    Dim lEntries As Long
    Dim lEntryCount As Long
    Dim dteMinute As Date
    Dim oSD As Object
    Dim varK As Variant, varI As Variant, varTemp As Variant, lIndex As Long
    Const dteMin As Date = 6.94444444444444E-04
    Dim lMinutesOverlap As Long
    Dim lOutputEntry As Long
    Dim sWorksheet As String
    Dim lNumberCount As Long
    Dim sOutput As String
    Dim lAreaCount As Long
    
    'Select a single contigious area, only rows that contain the date/times to be processed
    'Selection column A is date, D is start time, E is end time
    
    'Selection Error Checking
    lEntryCount = Selection.Rows.Count
    lAreaCount = Selection.Areas.Count
    
    If lEntryCount > 1 Then
        For Each rngCell In Intersect(Selection, Range("A:E").Cells)
            If IsNumeric(rngCell.Value2) Then
                lNumberCount = lNumberCount + 1
            End If
        Next
        If lNumberCount <> lEntryCount * 3 Then
            sOutput = "Bad selection, not all values in columns A,D:E of selected rows are numbers"
        End If
    Else
        sOutput = "Only 1 row selected"
    End If
    
    If lAreaCount > 1 Then
        sOutput = "More than one area selected"
    End If
    
    If sOutput <> vbNullString Then
        MsgBox sOutput, , "Exiting"
        GoTo End_Sub
    End If
    
    'Populating aryTimes with date/time data
    ReDim Preserve aryTimes(1 To 2, 1 To lEntryCount)
    For Each rngCell In Selection.Columns(1).Cells
        lEntries = lEntries + 1
        aryTimes(1, lEntries) = rngCell.Value2 + rngCell.Offset(0, 3).Value2
        aryTimes(2, lEntries) = rngCell.Value2 + rngCell.Offset(0, 4).Value2
    Next
    
    'Converting time intervals to 1 minute chunks, and populating scripting dictionary
    '  keys with that time and incrementing the associated SD item each time
    '  that key is seen.
    Set oSD = CreateObject("Scripting.Dictionary")  'SD are 0 indexed arrays)
    oSD.CompareMode = vbTextCompare
    For lEntries = 1 To lEntryCount
        For dteMinute = aryTimes(1, lEntries) To aryTimes(2, lEntries) Step dteMin
            'This method creates a key for dteMinute if it does not already exist
            oSD.Item(dteMinute) = oSD.Item(dteMinute) + 1
        Next
    Next
    
    'If any times were recorded, process them
    If oSD.Count > 0 Then
        ReDim varTemp(1 To 2, 1 To oSD.Count)
        varK = oSD.keys: varI = oSD.Items
        For lIndex = 1 To oSD.Count
            If varI(lIndex - 1) > 1 Then
                'Count keys that were duplicated (item > 1) (minutes with multiple entries)
                lOutputEntry = lOutputEntry + 1
                lMinutesOverlap = lMinutesOverlap + varI(lIndex - 1) - 1
                varTemp(1, lOutputEntry) = varK(lIndex - 1): varTemp(2, lOutputEntry) = varI(lIndex - 1)
            End If
        Next
    
        'Write to Worksheet
        sWorksheet = "Overlap Report"
        On Error Resume Next
        Application.DisplayAlerts = False
        Worksheets(sWorksheet).Delete
        Application.DisplayAlerts = True
        On Error GoTo 0
        Worksheets.Add(After:=Sheets(Sheets.Count)).Name = sWorksheet 'After last
        Range("A1").Resize(1, 2).Value = Array("Overlap Minutes)", "# Minutes this Minute")
        Range("A2").Resize(oSD.Count, 2).Value = Application.Transpose(varTemp)
        Columns.AutoFit
        
        MsgBox lMinutesOverlap & " minutes overlap."

    End If
    
End_Sub:
    
End Sub