Search code examples
excelvbalistbox

Display listbox according to current Application.UserName

I have a code here derived from an answer that displays listbox correctly in the current date. If I have a column B that stores different usernames, I want to insert this in the code:

If current username (Application.UserName) in the active form is equal to one of the names in column B then filter entries today for that username only

Current output:

Listbox is filtered in current date using the code below

Desired output

The same Listbox is filtered in the current date and current username using the code below with an additional code for username filtering

Update

This is the raw data:

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

Image of raw data: image of raw data

Updated derived code including the answer of Taller below:

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

It is getting the result for the declared username as per answer (in this case for McGrath) except that the date changed to 12:00:00 AM and Time became decimals in the result:

Excel result excel result

Listbox result listbox result

Thanks in advance for help

Solution

  • The updated code (marked with **) assumes user name is in column 3. Please update as needed.

    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

    Set date/time format before loading listbox

        dws.Columns("L:L").NumberFormatLocal = "m/d/yyyy"
    dws.Columns("M:M").NumberFormatLocal = "h:mm:ss AM/PM;@"