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

Question

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

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

我只是不知道应该在下面的代码中插入什么代码和哪一行。除了列表框已在当前日期中过滤之外，唯一要添加的是在其表单的当前用户名中过滤列表框。

电流输出：

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

所需输出

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

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

Answer 1

原帖未指定数据布局。更新后的代码（标有 **）假设用户名位于第 3 列中。

Const USER_COLUMN As Long = 3  ' ** Update as needed
Dim sUser as String ' **
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)
        If IsDate(sValue) Then
            If sValue = CriteriaDate AND sUser=Application.UserName 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