VBA Code to find overlapping time

muhleebbin

Board Regular
Joined
Sep 30, 2017
Messages
97
Office Version
  1. 365
  2. 2019
  3. 2016
  4. 2013
  5. 2010
Platform
  1. Windows
  2. MacOS
  3. Mobile
  4. Web
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
ABCDEFGHIJKLMNOPQRST
1DateJobTime InTime OutCost CodeHoursEarn CodePhasesort
21 - TestSubtotal Hours : 44.251
310/26/2020958 - Test1 - Test8:00 AM10:00 AM1503 - Gaging & rodding-2REG$0.00Test--Test--101 - Exterior Entry WayPending11/03/2020 4:52 pm UTC1.1
410/26/2020958 - Test1 - Test10:00 AM4:00 PM200 - Floor - Tile-6REG$0.00Test--Test--101 - Exterior Entry WayPending11/03/2020 4:53 pm UTC1.1
510/26/2020958 - Test1 - Test10:00 AM4:00 PM200 - Floor - Tile-6REG$0.00Test--Test--101 - Exterior Entry WayPending11/03/2020 4:54 pm UTC1.1
610/27/2020958 - Test1 - Test8:30 AM5:00 PM200 - Floor - Tile-8.5REG$0.00Test--Test--101 - Exterior Entry WayPending11/03/2020 4:56 pm UTC1.1
710/28/2020958 - Test1 - Test8:00 AM11:30 AM200 - Floor - Tile-3.5REG$0.00Test--Test--101 - Exterior Entry WayPending11/03/2020 4:57 pm UTC1.1
810/28/2020632 - Test21 - Test11:30 AM3:15 PM220 - Backsplash - Tile-3.75REG$0.00Test--Test--109 - KitchenPending11/03/2020 5:03 pm UTC1.1
910/29/2020632 - Test21 - Test7:00 AM2:30 PM220 - Backsplash - Tile-7.5REG$0.00Test--Test--109 - KitchenPending11/03/2020 5:05 pm UTC1.1
1010/30/2020632 - Test21 - Test7:30 AM2:30 PM220 - Backsplash - Tile-7REG$0.00Test--Test--108 - Media Room KitchenPending11/03/2020 5:07 pm UTC1.1
1144.25
124.25
133 - Test 3Subtotal Hours : 403
1410/26/2020957 - Test43 - Test 37:00 AM3:00 PM1513 - Pedestal set Pavers-8REG$0.00Test--Test6--105 - Deck PaversPending10/28/2020 12:17 am UTC3.1
1510/27/2020957 - Test43 - Test 37:00 AM3:00 PM1513 - Pedestal set Pavers-8REG$0.00Test--Test6--105 - Deck PaversPending10/28/2020 12:18 am UTC3.1
1610/28/2020957 - Test43 - Test 37:00 AM3:00 PM1513 - Pedestal set Pavers-8REG$0.00Test--Test6--105 - Deck PaversPending10/30/2020 1:43 pm UTC3.1
1710/29/2020957 - Test43 - Test 37:00 AM3:00 PM1513 - Pedestal set Pavers-8REG$0.00Test--Test6--105 - Deck PaversPending10/30/2020 1:44 pm UTC3.1
1810/30/2020957 - Test43 - Test 37:00 AM3:00 PM1513 - Pedestal set Pavers-8REG$0.00Test--Test6--105 - Deck PaversPending10/31/2020 2:19 pm UTC3.1
1940
200
Sheet1
Cell Formulas
RangeFormula
H11H11=SUM($H$3:$H$10)
H12H12=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)
H19H19=SUM($H$14:$H$18)
H20H20=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
CellConditionCell FormatStop If True
C14:C18Cell Valuecontains "1 - General Costs"textNO
D14Cell Valuecontains "1 - General Costs"textNO
F1,E376:E1048576,F375,F359:F370,E2:E358Cell Valuecontains "1 - General Costs"textNO


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.
 

Some videos you may like

Excel Facts

Shade all formula cells
To shade all formula cells: Home, Find & Select, Formulas to select all formulas. Then apply a light fill color.

pbornemeier

Well-known Member
Joined
May 24, 2005
Messages
3,889
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.

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

Watch MrExcel Video

Forum statistics

Threads
1,127,865
Messages
5,627,344
Members
416,242
Latest member
Kas O

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
Top