在 ComBox 更改后使用时间计算填充 ListBox

找到下面的代码，它将仅显示与组合框中选择的标准匹配的相关项目。

代码位于用户窗体模块中的几个子例程中。 代码注释中的详细说明。

代码（已测试）

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) = Format(tempArr(i, 4), "h:mm:ss") ' START
        LBDataArr(ArrIndex, 5) = Format(tempArr(i, 5), "h:mm:ss") ' 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

请测试下一个代码：

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

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

已编辑：

下一个版本也将过滤第六列（当前月份）上返回的数组，也会带来第七列。注意在 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)
• 确定保留月份名称的列，并在计算的第二部分使用它 （countsh.Range("x2:x" & lastR), curMonth)
• 在数组处理中使用上述列 NUMBER（）。arr(i, colNo) = curMonth