ComBox 更改后用时间计算填充列表框

我这里有一个简单的用户表单，它根据组合框的更改填充列表框。

组合框中唯一列表的代码：

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

原始数据更新（在Excel中添加了F列和G列） ***请不要介意列的排列方式，因为它们有其用途。

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):

***这是我更新的组合框更改与当前月份和列名称的期望结果（不需要在 Excel 工作表中具有总时间列，仅在列表框中）：

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

***更新了列表框所需的写作结果以及当前月份和列名称：

***更新了列表框所需的阅读结果以及当前月份和列名称：

Reading:

注意：月份格式为 Now，“mmmm” 过滤时不需要名称。只需要提出清单即可。

This question https://stackoverflow.com/questions/77037452/excel-vba-form-show-unique-entries-with-time-calculation-in-listbox也有计算，但它是针对唯一 ID 的。当前问题不需要是唯一的，只要列表框根据组合框选择进行填充即可。这里的答案1满足组合框更改后的显示，但列表框中没有时间计算或总计列（结束-开始）。答案2在Edit之前有时间计算但没有月份和列名；答案 2 中编辑的答案返回空白列表框。提前致谢。

请测试下一个代码：

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

当然，你必须根据你的需要设置每列的宽度。

Edited:

下一个版本也将在第六列（当前月份）上过滤返回的数组，同时也会引入第七列。请注意 G:G 列中包含 STRINGS 月份名称:

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

如果您需要收集更多列，请将它们放在最后四列之前。根据问题设计了一段代码。如果必须返回一个新列，代码可以相对容易地进行调整，但是如果您想要再返回一个，然后再返回另外两个，则处理起来会很困难。

如果您将所有这些添加到最后四个之前，如上所述，那么在仅调整下一个问题后它将运行良好：

• 将要处理的范围扩展到最后一列（arr = sh.Range("A2:x" & lastR).value)
• 识别保留月份名称的列并在第二部分中使用它count计算 （sh.Range("x2:x" & lastR), curMonth)
• 在数组处理中使用上述列 NUMBER (arr(i, colNo) = curMonth).