Cumulative time calculation considering overlaps and gaps in excel database

[martin_b4]

Dear members, sorry for long explanation. Already too much time spent on this and it is already really urgent..

Task is: calculate netto employment (in years, months and days) of thousands employees. Gaps in employment must be considered and not included into employment time, overlapping employments may not be double counted. Goal is to calculate total netto time of employment (years, months, days) and day of „anniversary“ i.e. when employee reaches another full year of employment. Thanks a lot.

 

[bebo021999]

Try with VBA code solution.
Press "RUN" button to generate

filled_example.xlsm

drive.google.com

Option Explicit
Sub employment()
Dim lr&, i&, j&, k&, min&, max&, rng, arr()
Dim dic As Object, key, sp, m&, d&
Set dic = CreateObject("Scripting.Dictionary")
lr = Cells(Rows.Count, "B").End(xlUp).Row
rng = Range("A3:E" & lr).Value2
ReDim arr(1 To UBound(rng), 1 To 5)
For i = 1 To UBound(rng)
    arr(i, 1) = rng(i, 1) & ""
    If Not dic.exists(rng(i, 1) & "-" & rng(i, 2)) Then
        dic.Add rng(i, 1) & "-" & rng(i, 2), "0|0|0"
        min = rng(i, 4): max = rng(i, 5)
    Else
        min = IIf(rng(i, 4) <= max, max, rng(i, 4))
        max = IIf(rng(i, 5) <= min, min, rng(i, 5))
    End If
    If rng(i, 5) = "" Then max = CLng(DateSerial(2023, 10, 31))
    arr(i, 2) = Evaluate("=datedif(" & min & ", " & max & ", ""y"")")
    arr(i, 3) = Evaluate("=datedif(" & min & ", " & max & ", ""ym"")")
    arr(i, 4) = Evaluate("=datedif(" & min & ", " & max & ", ""md"")")
Next
For Each key In dic.keys
    Debug.Print dic(key)
    For i = 1 To UBound(arr)
        If Split(key, "-")(0) = arr(i, 1) Then
            sp = Split(dic(key), "|")
            dic(key) = sp(0) + arr(i, 2) & "|" & sp(1) + arr(i, 3) & "|" & sp(2) + arr(i, 4)
            Debug.Print dic(key)
        End If
    Next
Debug.Print dic(key)
Next
i = 2: Range("L3:Q100000").ClearContents
For Each key In dic.keys
    sp = Split(dic(key), "|"): d = 0: m = 0
    If sp(2) > 30 Then
        d = sp(2) Mod 30
        sp(1) = sp(1) + Int(sp(2) / 30)
    End If
    If sp(1) > 12 Then
        m = sp(1) Mod 12
        sp(0) = sp(0) + Int(sp(1) / 12)
    End If
    i = i + 1
    Cells(i, "L").Value = Split(key, "-")(0)
    Cells(i, "M").Value = Split(key, "-")(1)
    Cells(i, "N").Value = sp(0)
    Cells(i, "O").Value = m
    Cells(i, "P").Value = d
    Cells(i, "Q").Value = Evaluate("=EDATE(DATE(2023,10,31),12-" & m & "-1)+30-" & d)
Next
Set dic = Nothing
End Sub

 

[martin_b4]

Try with VBA code solution.
Press "RUN" button to generate

filled_example.xlsm

drive.google.com

Option Explicit
Sub employment()
Dim lr&, i&, j&, k&, min&, max&, rng, arr()
Dim dic As Object, key, sp, m&, d&
Set dic = CreateObject("Scripting.Dictionary")
lr = Cells(Rows.Count, "B").End(xlUp).Row
rng = Range("A3:E" & lr).Value2
ReDim arr(1 To UBound(rng), 1 To 5)
For i = 1 To UBound(rng)
    arr(i, 1) = rng(i, 1) & ""
    If Not dic.exists(rng(i, 1) & "-" & rng(i, 2)) Then
        dic.Add rng(i, 1) & "-" & rng(i, 2), "0|0|0"
        min = rng(i, 4): max = rng(i, 5)
    Else
        min = IIf(rng(i, 4) <= max, max, rng(i, 4))
        max = IIf(rng(i, 5) <= min, min, rng(i, 5))
    End If
    If rng(i, 5) = "" Then max = CLng(DateSerial(2023, 10, 31))
    arr(i, 2) = Evaluate("=datedif(" & min & ", " & max & ", ""y"")")
    arr(i, 3) = Evaluate("=datedif(" & min & ", " & max & ", ""ym"")")
    arr(i, 4) = Evaluate("=datedif(" & min & ", " & max & ", ""md"")")
Next
For Each key In dic.keys
    Debug.Print dic(key)
    For i = 1 To UBound(arr)
        If Split(key, "-")(0) = arr(i, 1) Then
            sp = Split(dic(key), "|")
            dic(key) = sp(0) + arr(i, 2) & "|" & sp(1) + arr(i, 3) & "|" & sp(2) + arr(i, 4)
            Debug.Print dic(key)
        End If
    Next
Debug.Print dic(key)
Next
i = 2: Range("L3:Q100000").ClearContents
For Each key In dic.keys
    sp = Split(dic(key), "|"): d = 0: m = 0
    If sp(2) > 30 Then
        d = sp(2) Mod 30
        sp(1) = sp(1) + Int(sp(2) / 30)
    End If
    If sp(1) > 12 Then
        m = sp(1) Mod 12
        sp(0) = sp(0) + Int(sp(1) / 12)
    End If
    i = i + 1
    Cells(i, "L").Value = Split(key, "-")(0)
    Cells(i, "M").Value = Split(key, "-")(1)
    Cells(i, "N").Value = sp(0)
    Cells(i, "O").Value = m
    Cells(i, "P").Value = d
    Cells(i, "Q").Value = Evaluate("=EDATE(DATE(2023,10,31),12-" & m & "-1)+30-" & d)
Next
Set dic = Nothing
End Sub

Thank you so much! I have no experience with VBA so far but certainly Will try. Database Will be probably splitted into several files/parts, do you think that solution with SUMIFs andSUMPRODUCTs is possible?