Using VBA to Flag and Calculate Overlapping Shift Times

[Snort]

I have a list of punch times and I'm looking to find and calculate overlap without having to put everything on one row per Date of Service. My code contains a part created by ChatGPT that I think is trying to loop through the dictionary entries calculating overlap, but it's a bit advanced for me as I think it's dealing with Arrays which I don't yet understand, and I can't figure out why it's throwing errors.

I'm getting an error stating "Object variable or With block variable not set", and debug highlights "For Each Key in TimeInDicts(j).Keys" within the ChatGPT section of code.

The end goal is to identify not only overlap with other punch times in the same row, but also other punch times in other rows which overlap, as well as to calculate the overlap and list the File ID it overlaps with in it's own column next to the amount of time it overlaps. If it over laps with multiple rows, which I expect there to be numerous examples of, it should list the additional File ID's in added columns with the times. I haven't made it to this point in the code yet - got stuck with trying to get it to simply identify the overlap.

I tried to attach the Excel file and found I need to use XL2BB, but I cannot install things on the work computer, so here's a screenshot instead. Hopefully someone will be able to find the problem in the code even without the Excel file. I'd appreciate some help!

Option Explicit

Sub Overlap_Using_Dictionaries()
'Goal is to calculate overlap when times matched to claims as opposed to times on one row per DOS

Dim TimeIn1Dict As New Scripting.Dictionary
Dim TimeOut1Dict As New Scripting.Dictionary
Dim TimeIn2Dict As New Scripting.Dictionary
Dim TimeOut2Dict As New Scripting.Dictionary
Dim TimeIn3Dict As New Scripting.Dictionary
Dim TimeOut3Dict As New Scripting.Dictionary
Dim REMIn1Dict As New Scripting.Dictionary
Dim REMOut1Dict As New Scripting.Dictionary
Dim REMIn2Dict As New Scripting.Dictionary
Dim REMOut2Dict As New Scripting.Dictionary
Dim REMIn3Dict As New Scripting.Dictionary
Dim REMOut3Dict As New Scripting.Dictionary
Dim REMIn4Dict As New Scripting.Dictionary
Dim REMOut4Dict As New Scripting.Dictionary
Dim REMIn5Dict As New Scripting.Dictionary
Dim REMOut5Dict As New Scripting.Dictionary

Dim FileIDDict As New Scripting.Dictionary

Dim FileID As String
Dim FileIDCol As Long

Dim DOS As Long
Dim DOSCol As Long

'--Combine File ID and DOS for Dictionary Identifier Purposes--
Dim FileIDdos As String

'--Time In and Time Out--
Dim TI1 As Long
Dim TI1Col As Long
Dim TO1 As Long
Dim TO1Col As Long
Dim TI2 As Long
Dim TI2Col As Long
Dim TO2 As Long
Dim TO2Col As Long
Dim TI3 As Long
Dim TI3Col As Long
Dim TO3 As Long
Dim TO3Col As Long
Dim REMIn1 As Long
Dim REMIn1Col As Long
Dim REMOut1 As Long
Dim REMOut1Col As Long
Dim REMIn2 As Long
Dim REMIn2Col As Long
Dim REMOut2 As Long
Dim REMOut2Col As Long
Dim REMIn3 As Long
Dim REMIn3Col As Long
Dim REMOut3 As Long
Dim REMOut3Col As Long
Dim REMIn4 As Long
Dim REMIn4Col As Long
Dim REMOut4 As Long
Dim REMOut4Col As Long
Dim REMIn5 As Long
Dim REMIn5Col As Long
Dim REMOut5 As Long
Dim REMOut5Col As Long
'---------------------------

'---Last Row / Column-------
Dim Sht As Worksheet
Dim LastColumn As Long
Dim LastRow As Long
Dim C As Long
Dim R As Long

Sheets("Working").Select
Range("A1").Select

Set Sht = ActiveSheet

LastRow = Sht.Cells(Sht.Rows.Count, "A").End(xlUp).Row
LastColumn = Sht.Cells(1, Sht.Columns.Count).End(xlToLeft).Column

'---------------------------

Application.ScreenUpdating = False

For C = 1 To LastColumn

    If Cells(1, C) = "File ID" Then
        FileIDCol = C
    ElseIf Cells(1, C) = "Date of Service" Then
        DOSCol = C
    ElseIf Cells(1, C) = "Time In 1" Then
        TI1Col = C
    ElseIf Cells(1, C) = "Time Out 1" Then
        TO1Col = C
    ElseIf Cells(1, C) = "Time In 2" Then
        TI2Col = C
    ElseIf Cells(1, C) = "Time Out 2" Then
        TO2Col = C
    ElseIf Cells(1, C) = "Time In 3" Then
        TI3Col = C
    ElseIf Cells(1, C) = "Time Out 3" Then
        TO3Col = C
    ElseIf Cells(1, C) = "REM Time In 1" Then
        REMIn1Col = C
    ElseIf Cells(1, C) = "REM Time Out 1" Then
        REMOut1Col = C
    ElseIf Cells(1, C) = "REM Time In 2" Then
        REMIn2Col = C
    ElseIf Cells(1, C) = "REM Time Out 2" Then
        REMOut2Col = C
    ElseIf Cells(1, C) = "REM Time In 3" Then
        REMIn3Col = C
    ElseIf Cells(1, C) = "REM Time Out 3" Then
        REMOut3Col = C
    ElseIf Cells(1, C) = "REM Time In 4" Then
        REMIn4Col = C
    ElseIf Cells(1, C) = "REM Time Out 4" Then
        REMOut4Col = C
    ElseIf Cells(1, C) = "REM Time In 5" Then
        REMIn5Col = C
    ElseIf Cells(1, C) = "REM Time Out 5" Then
        REMOut5Col = C
    End If
Next C

'----------Assigning Times to Dictionaries----------------
For R = 2 To LastRow

    DOS = Cells(R, DOSCol)
    FileID = Cells(R, FileIDCol)
    FileIDdos = FileID & DOS
    
    TI1 = Cells(R, TI1Col)
    TO1 = Cells(R, TO1Col)
    TI2 = Cells(R, TI2Col)
    TO2 = Cells(R, TO2Col)
    TI3 = Cells(R, TI3Col)
    TO3 = Cells(R, TO3Col)
    REMIn1 = Cells(R, REMIn1Col)
    REMOut1 = Cells(R, REMOut1Col)
    REMIn2 = Cells(R, REMIn2Col)
    REMOut2 = Cells(R, REMOut2Col)
    REMIn3 = Cells(R, REMIn3Col)
    REMOut3 = Cells(R, REMOut3Col)
    REMIn4 = Cells(R, REMIn4Col)
    REMOut4 = Cells(R, REMOut4Col)
    REMIn5 = Cells(R, REMIn5Col)
    REMOut5 = Cells(R, REMOut5Col)
    
    If TI1 > 0 Then
        TimeIn1Dict.Add FileIDdos, TI1
        TimeOut1Dict.Add FileIDdos, TO1
        FileIDDict.Add FileIDdos, FileID
    End If
    
    If TI2 > 0 Then
        TimeIn2Dict.Add FileIDdos, TI2
        TimeOut2Dict.Add FileIDdos, TO2
    End If
    
    If TI3 > 0 Then
        TimeIn3Dict.Add FileIDdos, TI3
        TimeOut3Dict.Add FileIDdos, TO3
    End If
    
    If REMIn1 > 0 Then
        REMIn1Dict.Add FileIDdos, REMIn1
        REMOut1Dict.Add FileIDdos, REMOut1
    End If
    
    If REMIn2 > 0 Then
        REMIn2Dict.Add FileIDdos, REMIn2
        REMOut2Dict.Add FileIDdos, REMOut2
    End If
    
    If REMIn3 > 0 Then
        REMIn3Dict.Add FileIDdos, REMIn3
        REMOut3Dict.Add FileIDdos, REMOut3
    End If
    
    If REMIn4 > 0 Then
        REMIn4Dict.Add FileIDdos, REMIn4
        REMOut4Dict.Add FileIDdos, REMOut4
    End If
    
    If REMIn5 > 0 Then
        REMIn5Dict.Add FileIDdos, REMIn5
        REMOut5Dict.Add FileIDdos, REMOut5
    End If
    
Next R
    
'-----------------------------------------------------------

'----------Code from ChatGPT 3.5 on April 23, 2024-----------
'Sub FindOverlapForMultipleSets()
    Dim TimeInDicts(1 To 5) As Object
    Dim TimeOutDicts(1 To 5) As Object
    Dim REMInDicts(1 To 5) As Object
    Dim REMOutDicts(1 To 5) As Object
    Dim Key As Variant
    Dim StartTime As Date
    Dim EndTime As Date
    Dim ws As Worksheet
    Dim i As Long
    Dim j As Long
    Dim overlapFound As Boolean
    
    ' Assuming you have already populated the dictionaries
    
    ' Assign dictionaries to arrays
    Set TimeInDicts(1) = TimeIn1Dict
    Set TimeOutDicts(1) = TimeOut1Dict
    Set TimeInDicts(2) = TimeIn2Dict
    Set TimeOutDicts(2) = TimeOut2Dict
    Set TimeInDicts(3) = TimeIn3Dict
    Set TimeOutDicts(3) = TimeOut3Dict
    Set REMInDicts(1) = REMIn1Dict
    Set REMOutDicts(1) = REMOut1Dict
    Set REMInDicts(2) = REMIn2Dict
    Set REMOutDicts(2) = REMOut2Dict
    Set REMInDicts(3) = REMIn3Dict
    Set REMOutDicts(3) = REMOut3Dict
    Set REMInDicts(4) = REMIn4Dict
    Set REMOutDicts(4) = REMOut4Dict
    Set REMInDicts(5) = REMIn5Dict
    Set REMOutDicts(5) = REMOut5Dict
    
    ' Reference the active worksheet
    Set ws = ThisWorkbook.ActiveSheet
    
    ' Initialize row counter for output
    i = 2
    
    ' Loop through each set of punches
    For j = 1 To 5
        ' Loop through TimeInDict to find overlaps
'************************This is the line that is causing the error*************************        
           For Each Key In TimeInDicts(j).Keys
'******************************************************************************************           
            StartTime = TimeInDicts(j)(Key)
            EndTime = TimeOutDicts(j)(Key)
            
            ' Check for overlap
            If CheckOverlapForSets(TimeInDicts, TimeOutDicts, REMInDicts, REMOutDicts, Key, StartTime, EndTime, j) Then
                ' Output overlap information to column G
                ws.Cells(i, 7).Value = "Overlap found for FileIDdos " & Key & " - Set " & j & ": " & StartTime & " to " & EndTime
                i = i + 1 ' Move to the next row for the next overlap
                overlapFound = True ' Flag to indicate that overlap was found
            End If
        Next Key
    Next j
    
    ' If no overlaps were found, indicate it in column G
    If Not overlapFound Then
        ws.Cells(i, 7).Value = "No overlaps found."
    End If
'------End Code from Chat GPT---------------------------------

Application.ScreenUpdating = True

MsgBox "VBA Done"
    
End Sub

Function CheckOverlapForSets(TimeInDicts() As Object, TimeOutDicts() As Object, REMInDicts() As Object, REMOutDicts() As Object, Key As Variant, StartTime As Date, EndTime As Date, currentSet As Long) As Boolean
    'From ChatGPT 3.5 on April 23, 2024
    Dim TimeIn As Date
    Dim TimeOut As Date
    Dim REMIn As Date
    Dim REMOut As Date
    Dim j As Long
    
    ' Check if the current time range overlaps with any time range in the other dictionaries
    For j = 1 To 5
        If j <> currentSet Then
            For Each Key In TimeInDicts(j).Keys
                TimeIn = TimeInDicts(j)(Key)
                TimeOut = TimeOutDicts(j)(Key)
                REMIn = REMInDicts(j)(Key)
                REMOut = REMOutDicts(j)(Key)
                
                If (StartTime >= TimeIn And StartTime <= TimeOut) Or (EndTime >= TimeIn And EndTime <= TimeOut) Then
                    ' Overlap found
                    CheckOverlapForSets = True
                    Exit Function
                ElseIf (StartTime >= REMIn And StartTime <= REMOut) Or (EndTime >= REMIn And EndTime <= REMOut) Then
                    ' Overlap found
                    CheckOverlapForSets = True
                    Exit Function
                End If
            Next Key
        End If
    Next j
    
    ' No overlap found
    CheckOverlapForSets = False
End Function