Find the Code below, it will show only relevant items matching the criteria selected in the Combo-Box.

Code is located in a few Sub-routines within the User-Form Module. Detailed explanation inside the code s comments.

Code (tested)

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

当然,你必须根据你们的需要确定每个栏目。

http://www.ohchr.org。

下一个版本将过滤第6栏(现月)的返回阵列,使第七栏也出现。 Take Care to have the H:H栏被空,用于计算月份,以保持该代码的实际逻辑。 否则,我不得不作出更复杂的调整。 因此,你必须明确和全面地说明你在问题上的需要。

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, arrMonth 
  
  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 months number in H:H column:
      arrMonth = Evaluate("MONTH(" & sh.Range("F2:F" & lastR).address & ")")
      sh.Range("F2:F" & lastR).Offset(, 2).value = arrMonth
      
       calculate the necessary array elements:
      count = WorksheetFunction.CountIfs(sh.Range("A2:A" & lastR), ComboBox1.value, sh.Range("H2:H" & lastR), Month(Date))
      sh.Range("F2:F" & lastR).Offset(, 2).ClearContents  clear the months number in H:H
      If count > 0 Then
        ReDim arrFin(1 To count, 1 To UBound(arr, 2) - 1)
        For i = 1 To UBound(arr)
            If arr(i, 1) = ComboBox1.value And Month(arr(i, 6)) = Month(Date) 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) = Format(Date, "mmmm")
                    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