Populate ListBox with Time Calculation after ComBox change

Question

I have here a simple userform that populates listbox according to combobox change.

Code for unique list in combobox:

Private Sub UserForm_Initialize()
    'used this code to get a dynamic combobox unique Task list in Sheet1 Column A
    'but I wonder why there is an extra space after the last item in combobox
    Dim v, e
    With Sheets("Sheet1").Range("A2:A10000")
        v = .value
    End With
    With CreateObject("scripting.dictionary")
        .CompareMode = 1
        For Each e In v
            If Not .Exists(e) Then .Add e, Nothing
        Next
        If .Count Then Me.ComboBox1.List = Application.Transpose(.Keys)
    End With
End Sub

Raw Data Update (added Columns F and G in excel) ***Please don’t mind how the columns are arranged as they have a purpose.

Task     ||ID    ||PARAGRAPH #|| START        ||END       || Month    || Name
Writing  ||4823  ||  1        ||13:00:00      ||13:15:00  || January  || Larry
Reading  ||4823  ||  1        ||13:16:00      ||13:18:00  || February || Larry 
Writing  ||4823  ||  2        ||13:20:00      ||13:30:00  || March    || Larry
Reading  ||4823  ||  2        ||13:31:00      ||13:50:00  || April    || Larry
Writing  ||4824  ||  1        ||14:00:00      ||14:10:00  || October  || Cole
Reading  ||4824  ||  1        ||14:11:00      ||14:14:00  || October  || Cole

Image of Raw (added columns F and G):

***This is my updated desired outcome for combobox change with current Month and column Name (does not need to have a Total time column in excel sheet, only in listbox):

Private Sub ComboBox1_Change()
    If ComboBox1.value = "Writing" And Month = current month Then '***
    'if values are present then
    'calculate time (end - start) for Writing rows
    'populate listbox of Writing entries with Total Time Column, Month Column, Name Column
    'no need to populate start and end cols       

    'if there are no values found in Sheet1
    'ListBox1 is just blank

ElseIf ComboBox1.value = "Reading" and Month = current month Then '***
    'if values are present then
    'calculate time (end - start) for Reading rows
    'populate listbox of Reading entries with Total Time Column, Month Column, Name Column
    'no need to populate start and end cols     

    'if there are no values found in Sheet1
    'ListBox1 is just blank
End If
End Sub

***Updated ListBox desired Outcome for Writing and current Month and column Name:

***Updated ListBox desired Outcome for Reading and current Month and column Name:

Reading:

Note: Month format is Now, "mmmm" Name will not be required in filtering. Just needed to be brought up with the list.

This question also has calculation but it is for unique IDs. Current question does not need to be unique as long as listbox populates according to combobox selection. Answer 1 here satisfies the display after combobox change but no time calculation or Total column (end-start) in the listbox. Answer 2 before the Edit has time calculation but no month and column name; Edited answer in Answer 2 returns blank listbox. Thanks in advance.

Answer 1

Please, test the next code:

Private Sub ComboBox1_Change()
  Dim sh As Worksheet, lastR As Long, arr, arrFin, count As Long, i As Long, j As Long, k As Long
  
  Set sh = ActiveSheet 'use here the necessary one
  lastR = sh.Range("A" & sh.rows.count).End(xlUp).Row
  
      arr = sh.Range("A2:F" & lastR).value 'place the range in an array for faster processing
      count = WorksheetFunction.CountIf(sh.Range("A2:A" & lastR), ComboBox1.value) 'count the specific string occurrences
      If count > 0 Then
        ReDim arrFin(1 To count, 1 To UBound(arr, 2) - 1) 'redim the final aray
        For i = 1 To UBound(arr)
            If arr(i, 1) = ComboBox1.value Then
                k = k + 1
                For j = 1 To UBound(arrFin, 2)
                    If j = UBound(arrFin, 2) Then
                        arrFin(k, j) = Format(arr(i, j + 1) - arr(i, j), "hh:mm:ss")
                    Else
                        arrFin(k, j) = arr(i, j)
                    End If
                Next j
            End If
        Next i
      Else
        listBox1.Clear
      End If

     With listBox1
        .ColumnCount = UBound(arrFin, 2)
        .List = arrFin
     End With
End Sub

Of course, you have to set each columns width according to your needs..

Edited:

The next version will filter the returned array on the sixth column (current months), too, also bringing the seventh column. Take care to have STRINGS months name in G:G column:

Private Sub ComboBox1_Change()
  Dim sh As Worksheet, lastR As Long, arr, arrFin, count As Long, i As Long, j As Long, k As Long
  Dim arrMonths: arrMonths = Split("January,February,March,April,May,June,July,August,September,October,November,December", ",")
  Dim curMonth As String: curMonth = arrMonths(Month(Date) - 1)
  
  Set sh = ActiveSheet 'use here the necessary one
  lastR = sh.Range("A" & sh.Rows.count).End(xlUp).Row 'last row in the range to be processed
  
      arr = sh.Range("A2:G" & lastR).Value 'place the range in an array for faster processing
      
      'calculate the necessary array elements:
      count = WorksheetFunction.CountIfs(sh.Range("A2:A" & lastR), ComboBox1.Value, sh.Range("F2:F" & lastR), curMonth)

      If count > 0 Then
        ReDim arrFin(1 To count, 1 To UBound(arr, 2) - 1) 'redim the necessary array to keep the rows to be loaded in list box
        For i = 1 To UBound(arr)
            If arr(i, 1) = ComboBox1.Value And arr(i, 6) = curMonth Then
                k = k + 1
                For j = 1 To UBound(arrFin, 2)
                    If j = UBound(arrFin, 2) - 2 Then
                        arrFin(k, j) = Format(arr(i, j + 1) - arr(i, j), "hh:mm:ss")
                    ElseIf j = UBound(arrFin, 2) - 1 Then
                        arrFin(k, UBound(arrFin, 2) - 1) = curMonth
                    ElseIf j = UBound(arrFin, 2) Then
                        arrFin(k, UBound(arrFin, 2)) = arr(i, j + 1)
                    Else
                        arrFin(k, j) = arr(i, j)
                    End If
                Next j
            End If
        Next i
      Else
        ListBox1.Clear: Exit Sub
      End If

      With ListBox1
        .ColumnCount = UBound(arrFin, 2)
        .List = arrFin
      End With
End Sub

If you need to collect more columns, please place them before the last FOUR ones. A piece of code is designed according to the question. If a new column have to be returned, the code can be adapted relatively easily, but if you want another one and then other two, it will be difficult to be handled.

If you will add all of them before the last four, as mentioned above, it will work well after adapting only the next issues:

• extend the range to be processed up to the last column (arr = sh.Range("A2:x" & lastR).value)
• identify the column keeping the month names and use it in the second part of count calculation (sh.Range("x2:x" & lastR), curMonth)
• use the above mentioned column NUMBER in the array processing (arr(i, colNo) = curMonth).