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

Question

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

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

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

原始数据

Task     ||ID    ||PARAGRAPH #|| START        ||END   
Writing  ||4823  ||  1        ||13:00:00      ||13:15:00    
Reading  ||4823  ||  1        ||13:16:00      ||13:18:00    
Writing  ||4823  ||  2        ||13:20:00      ||13:30:00    
Reading  ||4823  ||  2        ||13:31:00      ||13:50:00    
Writing  ||4824  ||  1        ||14:00:00      ||14:10:00    
Reading  ||4824  ||  1        ||14:11:00      ||14:14:00

原始图像：

这是我想要的组合框更改结果（不需要在 Excel 工作表中具有总时间列）：

Private Sub ComboBox1_Change()
    If ComboBox1.value = "Writing" Then
        'if values are present then
       'calculate time (end - start) for Writing rows
        'populate listbox of Writing entries with Total Time Done 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" Then
    'if values are present then
    'calculate time (end - start) for Reading rows
    'populate listbox of Reading entries with Total Time Done 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

写作：

阅读：

这个问题也有计算，但它是针对唯一ID的。当前问题不需要是唯一的，只要列表框根据组合框选择进行填充即可。预先感谢。

Answer 1

找到下面的代码，它将仅显示符合组合框中所选条件的相关项目。

代码位于用户表单模块内的几个子例程中。 代码注释中有详细解释。

代码（已测试）

Option Explicit

Dim LBDataArr                   As Variant
Dim CBDataArr                   As Variant
Dim TaskSelectedStr             As String

' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

Private Sub ComboBox1_Change()

TaskSelectedStr = Me.ComboBox1.Value  ' save in User-Form Public variable

' ~~ Call Sub that loads only relevant Array items to List-Box, by matching the searched String in the current Combo-Box ~~~
LoadRelevantItemsToListBox

End Sub

' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

Private Sub UserForm_Initialize()

' ~~~ Call Sub that saves the data in "Sheet1" to arrays ~~~
ReadSheet1ToArray
    
   
With Me.ComboBox1
    .Clear
    .List = CBDataArr
End With

' --- populate List-Box ---
With Me.ListBox1
    .Clear
    .List = LBDataArr
End With

End Sub

' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

Sub ReadSheet1ToArray()

'======================================================================================================================
' Description : Sub reads all rows in "Sheet1" worksheet, to 'LBDataArr' 2-D array, and unique values of "Task" in
'               'CBDataArr' array.
'
' Caller(s)   : Sub 'UserForm_Initialize' (in this module)
'======================================================================================================================

Dim i As Long, LastRow As Long, ArrIndex As Long, MatchRow As Variant

Application.ScreenUpdating = False

' === Save "Materials DB" worksheet fields in 'TempArr' 2-D Array  ===
With ThisWorkbook.Sheets("Sheet1")
    LastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
    LBDataArr = .Range(.Cells(2, "A"), .Cells(LastRow, "E")).Value  ' save entire "Sheet1" worksheet contents in 2-D array
    
    ReDim CBDataArr(1 To LastRow)
    ArrIndex = 0
    
    ' --- Loop over LB Array and save only unique values in column A ---
    For i = 1 To UBound(LBDataArr, 1)
        If LBDataArr(i, 1) <> "" Then ' include only rows with text in them
            MatchRow = Application.Match(LBDataArr(i, 1), CBDataArr, 0)
            If IsError(MatchRow) Then
                ArrIndex = ArrIndex + 1
                CBDataArr(ArrIndex) = LBDataArr(i, 1)
            End If
        End If
    Next i
  
    If ArrIndex > 0 Then
        ReDim Preserve CBDataArr(1 To ArrIndex)
    End If
End With


Application.ScreenUpdating = True

End Sub

' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

Sub LoadRelevantItemsToListBox()

'======================================================================================================================
' Description : Sub scans through the entire 'LBDataArr' (read from "Sheet1" worksheet).
'               Per record tries to match the record's data with the values entered in 'Combo-Box1'
'
' Caller(s)   : ComboBox1_Change (Combo-Box Change event in this Module)
'======================================================================================================================

Dim i As Long, j As Long, LastRow As Long, Col As Long, ArrIndex As Long, MatchRow As Variant
Dim tempArr As Variant


Application.ScreenUpdating = False

' ~~~ Call Sub that reads all "Sheet1" to 'LBDataArr' 2-D Array ~~~
ReadSheet1ToArray

tempArr = LBDataArr ' save contents of array in 'Temp' array

ReDim LBDataArr(1 To UBound(tempArr, 1), 1 To 5) ' reset Array

ArrIndex = 0
   
' === loop through arrays >> faster ===
For i = 1 To UBound(tempArr, 1)
    If tempArr(i, 1) = TaskSelectedStr Then
        ' make sure current 'row' passes searched criteria --> add to Array (and List-Box)
        ArrIndex = ArrIndex + 1
        
        ' - I added the columns one by one in case you want to manipulate the daa in one of the columns -
        LBDataArr(ArrIndex, 1) = tempArr(i, 1) ' TASK
        LBDataArr(ArrIndex, 2) = tempArr(i, 2) ' ID
        LBDataArr(ArrIndex, 3) = tempArr(i, 3) ' PARAGRAPH #
        LBDataArr(ArrIndex, 4) = tempArr(i, 4) ' START
        LBDataArr(ArrIndex, 5) = tempArr(i, 5) ' END
    End If
Next i

' at least 1 record match the criteria in 'Task' Combo-Box
If ArrIndex >= 1 Then
    ' ~~~ Nice TRICK to redim first Dimension of 2-D array ~~~
    tempArr = LBDataArr
    ReDim LBDataArr(1 To ArrIndex, 1 To UBound(LBDataArr, 2))
    For i = 1 To ArrIndex
        For Col = 1 To UBound(LBDataArr, 2)
            LBDataArr(i, Col) = tempArr(i, Col)
        Next Col
    Next i
    
    With Me.ListBox1
        .Clear
        .List = LBDataArr
    End With
     
Else ' no result match
    Me.ListBox1.Clear

    MsgBox "No matches for the criteria entered in 'Task' Combo-Box '", vbCritical, "Search Null"
End If


Application.ScreenUpdating = True

End Sub