Excel Listbox Show entries entered in the current date only

Question

I would like to ask your help in showing the listbox entries in the current date only. I have here an example of entries entered in the previous dates and also entries for today's date. Everytime I enter another entry, entries in the previous dates still show. So what I would like to achieve is, when I enter another Color today, I will see the Colors entered today not including the Colors entered in the previous dates. Final output doesn't need to show in descending order. Please see the images below as it could help. In the first image, there is the sheet and the form. First and second fields are for date and time. Third field is for Color and there's the Submit button.

This is my code below:

Private Sub CommandButton1_Click()
    Dim Row As Long
    Row = ThisWorkbook.Sheets("ExcelEntryDB").Cells(Rows.Count, "A").End(xlUp).Row
    Me.ListBox1.ColumnCount = 3
    Me.ListBox1.ColumnHeads = True
    Me.ListBox1.ColumnWidths = "75;75;75"
    
    If Row > 1 Then
        Me.ListBox1.Rowsource = "ExcelEntryDB!C2:E" & Row
    Else
        Me.ListBox1.Rowsource = "ExcelEntryDB!C2:E2" & Row
    End If
    
    Dim sh As Worksheet
    Set sh = ThisWorkbook.Sheets("ExcelEntryDB")
    Dim n As Long
    
    n = sh.Range("C" & Application.Rows.Count).End(xlUp).Row
    sh.Range("C" & n + 1).Value = Format(Date, "mm/dd/yyyy")
    sh.Range("D" & n + 1).Value = Format(Time, "hh:nn:ss" AM/PM)
    sh.Range("E" & n + 1).Value = Me.TextBox3.Value
    
    Me.TextBox3.Value = ""
    
End Sub

This is my current display:

This is my desired output:

Is there a code I can insert somewhere in my code like:

If date = current date Then
    Listbox shows entry with current date 
End If

(Ascending order or just the normal order of how the listbox behaves; doesn't need to be descending order because descending has more calculations/arguments to do in the code)

Desired output is posted. Thank you.

Answer 1

Return Filtered Data in a Listbox

• The following will 'create a new range' with the headers and the matching data rows. It will then use this new range as the row source to populate the list box.
• It is assumed that the range starts with the first cell (SRC_FIRST_CELL) and has as many (consecutive) columns as there are column widths or column formats.

Private Sub CommandButton1_Click()
    
    ' Define constants.
    
    Const SRC_SHEET As String = "ExcelEntryDB"
    Const SRC_FIRST_CELL As String = "C1"
    Const DST_SHEET As String = "ExcelEntryDB" ' !!!
    Const DST_FIRST_CELL As String = "G1" ' !!!
    Const DST_COLUMN_FORMATS As String = "mm\/dd\/yyyy;hh:mm:ss AM/PM;@"
    Const DST_COLUMN_FORMATS_DELIMITER As String = ";"
    Const LBX_COLUMN_WIDTHS As String = "75;75;75"
    Const CRITERIA_COLUMN As Long = 1
    Const DST_SORT_COLUMN As Long = 2
    
    Dim dSortOrder As XlSortOrder: dSortOrder = xlDescending
    Dim CriteriaDate As Date: CriteriaDate = Date ' =TODAY()
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Write the source data to the source array.
    
    Dim cCount As Long: cCount = UBound(Split(LBX_COLUMN_WIDTHS, ";")) + 1
    
    Dim sws As Worksheet: Set sws = wb.Sheets(SRC_SHEET)
    Dim hrg As Range: Set hrg = sws.Range(SRC_FIRST_CELL).Resize(, cCount)
    
    Dim srg As Range, srCount As Long
    
    With hrg.Offset(1)
        Dim lCell As Range: Set lCell = .Resize(sws.Rows.Count - .Row + 1) _
            .Find("*", , xlFormulas, , xlByRows, xlPrevious)
        If lCell Is Nothing Then
            MsgBox "No data in worksheet.", vbCritical
            Exit Sub
        End If
        srCount = lCell.Row - .Row + 1
        Set srg = .Resize(srCount)
    End With
    
    ' Check if the date criterion was found.
    Dim crg As Range: Set crg = srg.Columns(CRITERIA_COLUMN)
    Dim drCount As Long:
    drCount = Application.CountIf(crg, CriteriaDate)
    If drCount = 0 Then
        MsgBox "No matches found.", vbCritical
        Exit Sub
    End If
    
    Dim sData(): sData = Union(hrg, srg).Value
    
    ' Return the headers and matching rows in the destination array.
    
    Dim dData(): ReDim dData(1 To drCount + 1, 1 To cCount)
    
    Dim sValue, sr As Long, dr As Long, c As Long, WriteRow As Boolean
    
    For sr = 1 To srCount
        If sr = 1 Then ' headers
            WriteRow = True
        Else ' data rows
            sValue = sData(sr, CRITERIA_COLUMN)
            If IsDate(sValue) Then
                If sValue = CriteriaDate Then
                    WriteRow = True
                End If
            End If
        End If
        If WriteRow Then
            WriteRow = False
            dr = dr + 1
            For c = 1 To cCount
                dData(dr, c) = sData(sr, c)
            Next c
        End If
    Next sr
    
    ' Write the values from the destination array to the destination range.
    
    Dim dws As Worksheet: Set dws = wb.Sheets(DST_SHEET)
    Dim drg As Range: Set drg = dws.Range(DST_FIRST_CELL).Resize(dr, cCount)
    
    drg.Value = dData
    drg.Resize(dws.Rows.Count - drg.Row - dr + 1).Offset(dr).Clear
    
    ' Sort and format the destination data range.
    
    ' Reference the destination data range (no headers).
    Dim ddrg As Range: Set ddrg = drg.Resize(dr - 1).Offset(1)
    
    ' Sort the data range.
    If DST_SORT_COLUMN >= 1 And DST_SORT_COLUMN <= cCount Then
        ddrg.Sort ddrg.Columns(DST_SORT_COLUMN), dSortOrder, , , , , , xlNo
    End If
    
    ' Write the formats to a string array.
    Dim dcFormats() As String:
    dcFormats = Split(DST_COLUMN_FORMATS, DST_COLUMN_FORMATS_DELIMITER)
    
    ' Apply the formats to each column of the data range.
    For c = 0 To UBound(dcFormats)
        ddrg.Columns(c + 1).NumberFormat = dcFormats(c)
    Next c
    
    ' Tie the row source of the listbox to the destination data range.
    ' The headers are automatically recognized.
    
    With Me.ListBox1
        .ColumnCount = cCount
        .ColumnHeads = True
        .ColumnWidths = LBX_COLUMN_WIDTHS
        .RowSource = ddrg.Address(External:=True)
    End With
    
End Sub