根据当前Application.UserName显示列表框

我这里有一个代码，源自在当前日期正确显示列表框的答案。如果我有一个存储不同用户名的 B 列，我想将其插入代码中：

如果活动表单中的当前用户名 (Application.UserName) 等于 B 列中的名称之一，则仅过滤当前该用户名的条目

电流输出：

使用下面的代码在当前日期过滤列表框

所需输出

使用下面的代码以及用于用户名过滤的附加代码在当前日期和当前用户名中过滤相同的列表框

更新

这是原始数据：

Username       ||Date            ||Start Time    ||Color

Murray, Leo W  ||9/24/2023       ||9:08:28 AM    ||white

Murray, Leo W  ||9/24/2023       ||9:10:06 AM    ||black

Murray, Leo W  ||9/24/2023       ||9:12:09 AM    ||gray

Murray, Leo W  ||9/24/2023       ||9:13:13 AM    ||blue

Murray, Leo W  ||9/24/2023       ||5:34:03 AM    ||yellow

Smith, Pia Y   ||9/24/2023       ||6:02:59 AM    ||green

Smith, Pia Y   ||9/24/2023       ||6:05:57 AM    ||red

McGrath, Sam O ||9/24/2023       ||6:09:30 AM    ||brown

McGrath, Sam O ||9/24/2023       ||6:13:59 AM    ||white

McGrath, Sam O ||9/24/2023       ||6:17:29 AM    ||green

McGrath, Sam O ||9/24/2023       ||6:38:55 AM    ||white

McGrath, Sam O ||9/24/2023       ||6:41:07 AM    ||gray

Blake, Gary K  ||9/24/2023       ||6:42:03 AM    ||red

Blake, Gary K  ||9/24/2023       ||6:43:31 AM    ||rare white

Blake, Gary K  ||9/24/2023       ||6:43:31 AM    ||rare white

Blake, Gary K  ||9/24/2023       ||8:52:26 AM    ||trial

McGrath, Sam O ||9/24/2023       ||7:59:33 PM    ||red

原始数据图像：

更新了派生代码，包括下面 Taller 的答案：

Private Sub defineConstants()
     ' Define constants.
Const SRC_SHEET As String = "ExcelEntryDB"
Const SRC_FIRST_CELL As String = "B1" ‘’’*************changed from C1 to B1
Const DST_SHEET As String = "ExcelEntryDB" ' !!!
Const DST_FIRST_CELL As String = "K1" ' !!! ‘’’’*************changed from H1 to K1
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;75"
Const USER_COLUMN As Long = 1 ‘’****************from the answer below
Const CRITERIA_COLUMN As Long = 2
Const DST_SORT_COLUMN As Long = 3
Dim dSortOrder As XlSortOrder: dSortOrder = xlDescending
'Dim CriteriaDate As Date: CriteriaDate = Date - (13 / 24) ' =TODAY()
Dim CriteriaDate As Date: CriteriaDate = Format(Date - (13 / 24), "mm/dd/yyyy")
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
        With Me.ListBox1
            .ColumnCount = cCount
            .ColumnHeads = True
            .ColumnWidths = LBX_COLUMN_WIDTHS
            '.RowSource = ddrg.Address(External:=True)
        End With
            Exit Sub
        End If
        srCount = lCell.Row - .Row + 2
       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
    Dim sUser As String '''''''''''''''''''''**from the answer
For sr = 1 To srCount
        If sr = 1 Then ' headers
            WriteRow = True
        Else ' data rows
            sValue = sData(sr, CRITERIA_COLUMN)
            sUser = sData(sr, USER_COLUMN) ‘’****************from the answer below
            If IsDate(sValue) Then
                If sValue = CriteriaDate And sUser = "McGrath, Sam O" Then ‘’****************from the answer below
                '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.
         If dr = 1 Then
            MsgBox "Nothing"
        End If
        ' 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

它正在根据答案获取声明的用户名的结果（在本例中为 McGrath），除了日期更改为 12:00:00 AM 并且时间在结果中变为小数：

Excel结果

列表框结果

预先感谢您的帮助