Case with Date condition/filter VBA

Using the previous post, I have added:

New columns which are Name and Date
New 6 labels (Dan's daily and monthly counts, Lisa's daily and monthly counts, total daily count and monthly counts)
New listbox2

I am having a problem on how to insert a date filtering condition in the case where Listbox1's result is for today's inputs (daily) while the Listbox2 is for the month's inputs (monthly).

This is the raw data from 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

This is the code derived:

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

This is the desired output:

How to get the listboxes as per daily and monthly date filter as well as the counts in labels?

Solution

Add the 2nd collection to store the desired data rows for ListBox2.

Note: Listbox column headers can't set by .List property. Please refer to your previous post:

How to show the last 10 entries in listbox made VBA

Option Explicit

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, iDate As Date
    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
                iDate = CDate(sData(sr, DATE_COLUMN))
                If Month(iDate) = Month(Date) And Year(iDate) = Year(Date) Then
                    coll2.Add sr ' for ListBox2
                    If CDbl(iDate) = CDbl(Date) Then
                        coll1.Add sr ' for ListBox1
                    End If
                End If
            End If
        End Select
    Next sr
    
    ' Define the destination array
    Dim dData() As Variant
    ' ** for ListBox 2
    If coll2.Count = 0 Then Exit Sub
    Col2Arr coll2, dData, sData, ColumnsCount
    With Me.ListBox2
        .ColumnHeads = False
        .ColumnWidths = "30,30,50,30"
        .ColumnCount = ColumnsCount
        .List = dData
    End With
    ' ** for ListBox 1
    If coll1.Count = 0 Then Exit Sub
    Col2Arr coll1, dData, sData, ColumnsCount
    With Me.ListBox1
        .ColumnHeads = False
        .ColumnWidths = "30,30,50,30"
        .ColumnCount = ColumnsCount
        .List = dData
    End With
    
End Sub

Sub Col2Arr(ByRef Col As Collection, ByRef dData As Variant, _
        ByVal sData As Variant, ByVal ColumnsCount As Long)
    Dim dRowsCount As Long: dRowsCount = Col.Count
    ReDim dData(1 To dRowsCount + 1, 1 To ColumnsCount)
    Dim c As Long, srItem
    For c = 1 To ColumnsCount
        dData(1, c) = sData(1, c)
    Next
    Dim dr As Long: dr = 1
    For Each srItem In Col
        dr = dr + 1
        For c = 1 To ColumnsCount
            dData(dr, c) = sData(srItem, c)
        Next c
    Next srItem
End Sub