Excel 列表框仅显示当前日期输入的条目

Question

我想请求您帮助仅显示当前日期的列表框条目。我这里有一个示例，其中包含先前日期输入的条目以及今天日期的条目。每次我输入另一个条目时，之前日期的条目仍然会显示。所以我想实现的是，当我今天输入另一种颜色时，我将看到今天输入的颜色，不包括之前日期输入的颜色。最终输出不需要按降序显示。请参阅下面的图片，因为它会有所帮助。在第一张图片中，有表格和表格。第一个和第二个字段用于日期和时间。第三个字段用于颜色，并且有“提交”按钮。

这是我的代码：

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

这是我当前的显示：

这是我想要的输出：

我可以在代码中的某个位置插入一段代码吗，例如：

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

（升序或列表框行为的正常顺序；不需要降序，因为降序在代码中需要执行更多计算/参数）

已发布所需的输出。谢谢你。

Answer 1

在列表框中返回过滤后的数据

• 以下内容将使用标题和匹配的数据行“创建一个新范围”。然后，它将使用这个新范围作为行源来填充列表框。
• 假设范围从第一个单元格 (

  SRC_FIRST_CELL

  ) 开始，并且具有与列宽度或列格式一样多的（连续）列。

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
    
    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 c As Long
    
    ' Write headers.
    For c = 1 To cCount
        dData(1, c) = sData(1, c)
    Next c
    
    Dim dr As Long: dr = 1 ' skip headers
    
    Dim sValue, sr As Long
    
    ' Write data.
    For sr = 1 To srCount
        sValue = sData(sr, CRITERIA_COLUMN)
        If IsDate(sValue) Then
            If sValue = CriteriaDate Then
                dr = dr + 1
                For c = 1 To cCount
                    dData(dr, c) = sData(sr, c)
                Next c
            End If
        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
    
    ' Format the destination data columns.
    
    ' Reference the destination data range (no headers).
    Dim ddrg As Range: Set ddrg = drg.Resize(dr - 1).Offset(1)
    
    ' 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.
    With ddrg
        For c = 0 To UBound(dcFormats)
            .Columns(c + 1).NumberFormat = dcFormats(c)
        Next c
    End With
    
    ' 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