How to Populate ListBox2 with Average Total Time without Unique IDs

I have here a simple Excel Sheet with data below.

Excel Raw Text

YEAR    ID  Work        Time_In     Time_Out    Total_Hours
2023    111 Carpenter   11:00:00    12:00:00    1:00:00
2023    111 Painter     8:00:00     8:30:00     0:30:00
2023    112 Dancer      9:00:00     10:25:00    1:25:00
2023    113 Singer      10:00:00    11:10:00    1:10:00
2023    113 Singer      11:00:00    11:20:00    0:20:00
2023    113 Carpenter   13:00:00    13:10:00    0:10:00
2023    114 Painter     13:40:00    14:00:00    0:20:00
2023    114 Singer      14:40:00    15:35:00    0:55:00
2024    111 Carpenter   11:00:00    11:10:00    0:10:00

My post is almost the same with this post. But for my current post (this question), I do not have unique IDs in the ID column. IDs can repeat with different Works.

This is my form:

I have managed to get the number of entries (in labels) per Work using this code below.

Option Explicit
Sub firstlistdisplay()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim Work() As Variant
    Dim Year() As Variant
    Dim i As Long, j As Long, k As Long
    Dim dict As Object, key As Variant
    
    Year = Array("2023", "2024")
    Work = Array("Carpenter", "Painter", "Dancer", "Singer")
    
    Set dict = CreateObject("Scripting.Dictionary") 'Initialize Dictionary
 
    Set ws = ThisWorkbook.Worksheets("Sheet2")

    lastRow = ws.Cells(ws.Rows.count, "A").End(xlUp).Row

    
    For i = 1 To lastRow
        key = ws.Cells(i, 1).Value & "_" & ws.Cells(i, 3).Value & "_" & ws.Cells(i, 2).Value
        If Not dict.Exists(key) Then
            dict.Add key, 1
        End If
    Next i
        For j = LBound(Year) To UBound(Year)
            Dim TotalCount As Long
            TotalCount = 0
            For k = LBound(Work) To UBound(Work) 'Loop through Work
                Dim iCarpenter As Long
                Dim iPainter As Long
                Dim iDancer As Long
                Dim iSinger As Long
                
                iCarpenter = 0
                iPainter = 0
                iDancer = 0
                iSinger = 0
                
                For Each key In dict.Keys
                    If InStr(key, "Carpenter") > 0 Then
                        iCarpenter = iCarpenter + 1
                    ElseIf InStr(key, "Painter") > 0 Then
                        iPainter = iPainter + 1
                    ElseIf InStr(key, "Dancer") > 0 Then
                        iDancer = iDancer + 1
                    ElseIf InStr(key, "Singer") > 0 Then
                        iSinger = iSinger + 1
                    End If
                Next key
                Me.Label1.Caption = iCarpenter
                Me.Label2.Caption = iPainter
                Me.Label3.Caption = iDancer
                Me.Label4.Caption = iSinger
            Next k
        Next j
End Sub

However, for the desired output in the form image above, I do not know how to code for it.

Please advise. Thank you..

Solution

Using two Dict objects to summarize data

Option Explicit

Private Sub UserForm_Initialize()
    Dim ws As Worksheet
    Dim lastRow As Long, Work, Labels
    Dim arrList(), i As Long
    Dim cntDict As Object, sumDict As Object, key As Variant
    ' Label1~Label4 is in same order as Work
    Work = Array("Carpenter", "Painter", "Dancer", "Singer")
    Labels = Array("lab_Carpenter", "lab_Painter", "lab_Dancer", "lab_Singer")
    Set cntDict = CreateObject("Scripting.Dictionary") 'Initialize Dictionary
    Set sumDict = CreateObject("Scripting.Dictionary")
    Set ws = ThisWorkbook.Worksheets("Sheet2")
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    For i = 1 To lastRow
        key = ws.Cells(i, 3).Value
        If Not cntDict.Exists(key) Then
            cntDict.Add key, 1
            sumDict.Add key, ws.Cells(i, 6).Value
        Else
            cntDict(key) = cntDict(key) + 1
            sumDict(key) = sumDict(key) + ws.Cells(i, 6).Value
        End If
    Next i
    ReDim arrList(cntDict.Count, 1 To 3)
    arrList(0, 1) = "Work"
    arrList(0, 2) = "Total_Hours"
    arrList(0, 3) = "Average"
    For i = 0 To UBound(Work)
        key = Work(i)
        arrList(i + 1, 1) = key
        arrList(i + 1, 2) = Format(sumDict(key), "h:mm:ss")
        arrList(i + 1, 3) = Format(sumDict(key) / cntDict(key), "h:mm:ss")
        ' Predefined lables name with array
        Me.Controls(Labels(i)).Caption = cntDict(key)
        ' If label controls name follow a pattern         
        ' Me.Controls("lab_" & key).Caption = cntDict(key)
    Next
    With Me.ListBox2
        .ColumnCount = 3
        .List = arrList
    End With
End Sub