带有日期条件/过滤器VBA的案例

Question

使用上一篇文章，我添加了：

• 新列名称和日期
• 新增 6 个标签（Dan 的每日和每月计数、Lisa 的每日和每月计数、每日总计数和每月计数）
• 新列表框2

在 Listbox1 的结果是今天的输入（每日）而 Listbox2 的结果是当月的输入（每月）的情况下，我遇到了如何插入日期过滤条件的问题。

这是Excel Sheet1的原始数据：

ID      Name    Status      Date
1201    Lisa    Pending A   10/14/2024
1202    Lisa    In progress 10/15/2024
1203    Dan     Pending A   10/16/2024
1204    Dan     Pending B   10/17/2024
1205    Dan     Pending C   10/17/2024
1206    Dan     Pending B   10/18/2024
1207    Lisa    Pending B   10/19/2024
1208    Dan     Pending B   10/19/2024
1209    Lisa    Pending A   10/19/2024

这是导出的代码：

Private Sub UserForm_Initialize()
        
    ' Define constants.
    Const CRITERIA_COLUMN As Long = 3
    
    ' Return the values of the range in an array.
    Dim wb As Workbook: Set wb = ThisWorkbook
    Dim ws As Worksheet: Set ws = wb.Sheets("Sheet1")
    Dim rng As Range:
    Set rng = ws.Range("A1:D" & ws.Cells(ws.Rows.count, "C").End(xlUp).Row)
    Dim sRowsCount As Long: sRowsCount = rng.Rows.count
    Dim ColumnsCount As Long: ColumnsCount = rng.Columns.count
    Dim sData() As Variant: sData = rng.Value
    
    ' Return the matching source row numbers in a collection.
    Dim coll As Collection: Set coll = New Collection
    Dim sr As Long
    For sr = 2 To sRowsCount
        Select Case CStr(sData(sr, CRITERIA_COLUMN))
            Case "Pending A", "Pending B" '**** would like to put a date condition here or anywhere in the whole code to get result
                coll.Add sr
        End Select
    Next sr
    
    ' Define the destination array
    Dim dRowsCount As Long: dRowsCount = coll.count
    If dRowsCount = 0 Then Exit Sub ' no matches
    Dim dData() As Variant: ReDim dData(1 To dRowsCount, 1 To ColumnsCount)
    
    ' Loop through the items (matching source rows) of the collection
    ' to populate the destination array.
    Dim srItem As Variant, dr As Long, c As Long
    For Each srItem In coll
        dr = dr + 1
        For c = 1 To ColumnsCount
            dData(dr, c) = sData(srItem, c)
        Next c
    Next srItem
         
    ' Populate the listbox...
    With Me.ListBox1
        .ColumnHeads = True
        .ColumnWidths = "30,30,50,30"
        .ColumnCount = ColumnsCount
        .List = dData
    End With
    
    With Me.ListBox2
        .ColumnHeads = True
        .ColumnWidths = "30,30,50,30"
        .ColumnCount = ColumnsCount
        '.List = dData
    End With
    
    ' ... and the label.
    'LabelDanDaily.Caption =
    'LabelLisaDaily.Caption =
    
    'LabelDanMonthly.Caption =
    'LabelLisaMonthly.Caption =
    
    'LabelTotalDaily.Caption =
    LabelTotalMonthly.Caption = dRowsCount
        
End Sub

这是所需的输出：

请指教。

Answer 1

在 DATE_COLUMN 上筛选所需列表。

注意：列表框列标题不能通过

.List

属性设置。请参考您之前的帖子：

如何用VBA显示列表框中的最后10个条目

Private Sub UserForm_Initialize()
    
    ' Define constants.
    Const CRITERIA_COLUMN As Long = 3
    Const DATE_COLUMN As Long = 4
    
    ' Return the values of the range in an array.
    Dim wb As Workbook: Set wb = ThisWorkbook
    Dim ws As Worksheet: Set ws = wb.Sheets("Sheet1")
    Dim rng As Range:
    Set rng = ws.Range("A1:D" & ws.Cells(ws.Rows.Count, "C").End(xlUp).Row)
    Dim sRowsCount As Long: sRowsCount = rng.Rows.Count
    Dim ColumnsCount As Long: ColumnsCount = rng.Columns.Count
    Dim sData() As Variant: sData = rng.Value
    
    ' Return the matching source row numbers in a collection.
    Dim coll1 As Collection: Set coll1 = New Collection
    Dim coll2 As Collection: Set coll2 = New Collection
    Dim sr As Long
    For sr = 2 To sRowsCount
        Select Case CStr(sData(sr, CRITERIA_COLUMN))
        Case "Pending A", "Pending B" '**** would like to put a date condition here or anywhere in the whole code to get result
            If IsDate(sData(sr, DATE_COLUMN)) Then
                If Month(CDate(sData(sr, DATE_COLUMN))) = Month(Date) Then
                    coll2.Add sr ' for ListBox2
                    If CDbl(CDate(sData(sr, DATE_COLUMN))) = CDbl(Date) Then
                        coll1.Add sr ' for ListBox1
                    End If
                End If
            End If
        End Select
    Next sr
    
    ' Define the destination array
    Dim dRowsCount As Long: dRowsCount = coll1.Count
    If dRowsCount = 0 Then Exit Sub ' no matches
    Dim dData() As Variant: ReDim dData(1 To dRowsCount, 1 To ColumnsCount)
    
    ' Loop through the items (matching source rows) of the collection
    ' to populate the destination array.
    Dim srItem As Variant, dr As Long, c As Long
    For Each srItem In coll1
        dr = dr + 1
        For c = 1 To ColumnsCount
            dData(dr, c) = sData(srItem, c)
        Next c
    Next srItem
    
    ' Populate the listbox1...
    With Me.ListBox1
        .ColumnHeads = True
        .ColumnWidths = "30,30,50,30"
        .ColumnCount = ColumnsCount
        .List = dData
    End With
    ' ** for ListBox 2
    ' Define the destination array
    dRowsCount = coll2.Count
    If dRowsCount = 0 Then Exit Sub ' no matches
    ReDim dData(1 To dRowsCount, 1 To ColumnsCount) ' reset array
    ' Loop through the items (matching source rows) of the collection
    ' to populate the destination array.
    dr = 0
    For Each srItem In coll2
        dr = dr + 1
        For c = 1 To ColumnsCount
            dData(dr, c) = sData(srItem, c)
        Next c
    Next srItem
    
    With Me.ListBox2
        .ColumnHeads = True
        .ColumnWidths = "30,30,50,30"
        .ColumnCount = ColumnsCount
        .List = dData
    End With
    
    ' ... and the label.
    'LabelDanDaily.Caption =
    'LabelLisaDaily.Caption =
    
    'LabelDanMonthly.Caption =
    'LabelLisaMonthly.Caption =
    
    'LabelTotalDaily.Caption =
    ' LabelTotalMonthly.Caption = dRowsCount
    
End Sub