Shiela's questions

Tenho uma planilha dinâmica aqui que gostaria de exibir apenas na caixa de listagem, colunas de A a F com coluna A/Nome diferente de célula nula/vazia.

Tentei isso abaixo durante a inicialização:

Sub forListBoxShow()
    Dim ws As Worksheet, colList As Collection
    Dim arrData, arrList, i As Long, j As Long
    Set colList = New Collection
    Set ws = Worksheets("Sheet1")
    arrData = ws.Range("A1:F" & ws.Cells(ws.Rows.count, "A").End(xlUp).Row)
    ' build collection of row numbers
    For i = 2 To UBound(arrData)
            If arrData(i, 1) <> vbNullString Then
                colList.Add i, CStr(i)
            End If
    Next
    ReDim arrList(1 To colList.count + 1, 1 To UBound(arrData))
    For j = 1 To 6
        arrList(1, j) = arrData(1, j) ' header
        For i = 1 To colList.count
                arrList(i + 1, j) = arrData(colList(i), j)
        Next
    Next
    listBoxShow.Clear
    With Me.listBoxShow
        .ColumnCount = UBound(arrData, 2)
        .ColumnWidths = "50,50,70,40,90,90"
        .list = arrList
    End With
End Sub

Mas estou recebendo subscript out of rangeerro. Também tentei adicionar valores reais a células que têm #VALUE!como Nome, "Mark", mas tenho o mesmo erro. (Para células com #VALUE! - tem fórmula padrão e tem propósito). Também tentei isso para o código acima, mas tenho o mesmo erro:

If Not arrData(i, 1) = "" Then

Agradeço sua ajuda.

Tenho dados brutos aqui.

Column B = Score- Dinâmica vinda dos usuários

Column C = Complexity (from users) and Column D = Pointstem tabela fixa. Na imagem abaixo, o usuário coloca em branco/sem Complexidade.

Imagem 1

Column D = Points

Formula:
=IFERROR(VLOOKUP(C2,L1:M6,2,FALSE),"-")

Column E: Total with Points is based on sum of Score (B) and Points (D) divided by 5 (highest complexity of table).O formato da coluna é em Porcentagem.

Formula:
=(B2+D2)/5

Column F: Total without Points is based on Score (B) divided by 5 (highest complexity).O formato da coluna é em Porcentagem.

Formula:
=B2/5

Todas as fórmulas acima são aplicadas a cada coluna respectiva. Agora, estou obtendo 100,00% para a célula F4 por causa da fórmula aplicada para a coluna F. Por favor, veja a Imagem 1.

Como colocar uma fórmula para esta coluna que também mostrará um valor de erro se a célula da esquerda tiver um valor de erro, mas ainda dará o resultado para todas as outras células com valores usando (=B2/5).

Desejado:

Imagem2

Agradeço sua ajuda.

Por favor, tenha paciência comigo, pois sou novo no Access VBA.

Tenho aqui um subformulário com uma planilha de dados que gostaria de exibir na Visualização Pop-Up.

Se o Pop Up for Não, ele exibirá a página inteira.

Se o Pop Up for Sim, ele exibirá apenas isto abaixo:

Estas são minhas propriedades:

Tentei definir o Redimensionamento automático como Não, e acontece a mesma coisa.

O que devo definir aqui nas propriedades para que pelo menos isso seja exibido automaticamente abaixo:

Aparecer

Por favor, tenha paciência comigo, pois sou novo no Access VBA.

Tenho uma caixa de texto aqui no Form2 nomeada txtEIDcom um Employee IDvalor que é passado de outro formulário.

Também tenho uma caixa de texto de exemplo chamada txtFullNameque deve preencher automaticamente o nome de uma pessoa da tabela tblEmployeescom campo de tabela EmployeeNameonde Form2.txtEID.valueé igual a EIDde tblEmployees.

Não sei como fazer o preenchimento automático na caixa de texto, mas para meu teste, tentei em uma ComboBox com esta linha abaixo em sua propriedade Rowsource:

SELECT [tblEmployees].[ID], [tblEmployees].[EmployeeName] FROM tblEmployees WHERE [tblEmployees].[EID] = [txtEID]; 

Ele está mostrando o valor desejado (nome da pessoa com base no EID de txtEID) no ComboBox, mas apenas como uma lista suspensa.

Como posso definir o valor da caixa de texto txtFullNamepara o nome de uma pessoa da tabela com base no EID exibido em txtEID. Também não sei como configurá-lo na txtFullNamepropriedade Control Source.

Esse tem sido meu problema por 6 horas. Sua ideia é muito apreciada.

Sou novo no Access e tenho um código aqui abaixo que deve inserir o mês atual em uma tabela através da data atual que tenho no meu PC subtraído de 1 hora:

strSQL = "INSERT INTO [mytable] ([monthColumn]) "
strSQL = strSQL & "VALUES ("
strSQL = strSQL & "#" & Format(Now - (1 / 24), "mmmm") & "#"
strSQL = strSQL & ");"

DoCmd.SetWarnings False
DoCmd.RunSQL (strSQL)
DoCmd.SetWarnings True

Eu também tentei isso:

strSQL = "INSERT INTO [mytable] ([monthColumn]) VALUES (#" & Format(Now - (1 / 24), "mmmm") & "#);"

DoCmd.SetWarnings False
DoCmd.RunSQL (strSQL)
DoCmd.SetWarnings True

Para ambos os códigos, estou recebendo este erro:

Eu apenas derivei os códigos acima de um código funcional abaixo:

strSQL = "INSERT INTO [mytable] ([monthColumn]) VALUES (#" & Now() & "#);"

O que pode estar faltando? Obrigado antecipadamente.

Tenho aqui um combobox que está obtendo valores de uma coluna Date de uma tabela. Então é assim que parece:

Existe alguma maneira de converter a lista de datas da caixa de combinação em meses distintos como este abaixo?

Dei uma olhada nesse método na resposta, mas ele está sendo usado no Excel e eu estou no Access e ainda sou novo no Access.

Ajuda é muito apreciada. Obrigado antecipadamente.

Usando o post anterior , adicionei:

• Novas colunas que são Nome e Data
• Novos 6 rótulos (contagens diárias e mensais de Dan, contagens diárias e mensais de Lisa, contagem diária total e contagens mensais)
• Nova listbox2

Estou tendo um problema sobre como inserir uma condição de filtragem de data no caso em que o resultado do Listbox1 é para as entradas de hoje (diário), enquanto o Listbox2 é para as entradas do mês (mensal).

Estes são os dados brutos da Planilha Excel 1:

ID      Name    Status      Date
1201    Lisa    Pending A   10/14/2024
1202    Lisa    In progress 10/15/2024
1203    Dan     Pending A   10/16/2024
1204    Dan     Pending B   10/17/2024
1205    Dan     Pending C   10/17/2024
1206    Dan     Pending B   10/18/2024
1207    Lisa    Pending B   10/19/2024
1208    Dan     Pending B   10/19/2024
1209    Lisa    Pending A   10/19/2024

Este é o código derivado:

Private Sub UserForm_Initialize()
        
    ' Define constants.
    Const CRITERIA_COLUMN As Long = 3
    
    ' Return the values of the range in an array.
    Dim wb As Workbook: Set wb = ThisWorkbook
    Dim ws As Worksheet: Set ws = wb.Sheets("Sheet1")
    Dim rng As Range:
    Set rng = ws.Range("A1:D" & ws.Cells(ws.Rows.count, "C").End(xlUp).Row)
    Dim sRowsCount As Long: sRowsCount = rng.Rows.count
    Dim ColumnsCount As Long: ColumnsCount = rng.Columns.count
    Dim sData() As Variant: sData = rng.Value
    
    ' Return the matching source row numbers in a collection.
    Dim coll As Collection: Set coll = New Collection
    Dim sr As Long
    For sr = 2 To sRowsCount
        Select Case CStr(sData(sr, CRITERIA_COLUMN))
            Case "Pending A", "Pending B" '**** would like to put a date condition here or anywhere in the whole code to get result
                coll.Add sr
        End Select
    Next sr
    
    ' Define the destination array
    Dim dRowsCount As Long: dRowsCount = coll.count
    If dRowsCount = 0 Then Exit Sub ' no matches
    Dim dData() As Variant: ReDim dData(1 To dRowsCount, 1 To ColumnsCount)
    
    ' Loop through the items (matching source rows) of the collection
    ' to populate the destination array.
    Dim srItem As Variant, dr As Long, c As Long
    For Each srItem In coll
        dr = dr + 1
        For c = 1 To ColumnsCount
            dData(dr, c) = sData(srItem, c)
        Next c
    Next srItem
         
    ' Populate the listbox...
    With Me.ListBox1
        .ColumnHeads = True
        .ColumnWidths = "30,30,50,30"
        .ColumnCount = ColumnsCount
        .List = dData
    End With
    
    With Me.ListBox2
        .ColumnHeads = True
        .ColumnWidths = "30,30,50,30"
        .ColumnCount = ColumnsCount
        '.List = dData
    End With
    
    ' ... and the label.
    'LabelDanDaily.Caption =
    'LabelLisaDaily.Caption =
    
    'LabelDanMonthly.Caption =
    'LabelLisaMonthly.Caption =
    
    'LabelTotalDaily.Caption =
    LabelTotalMonthly.Caption = dRowsCount
        
End Sub

Esta é a saída desejada:

Como obter as caixas de listagem de acordo com o filtro de data diário e mensal, bem como as contagens nos rótulos?

Tenho aqui a Folha 1 que contém um número de identificação que inseri manualmente.

Folha1

O que eu gostaria de fazer com este número de ID é vincular à Folha 2 selecionando o(s) mesmo(s) número(s) de ID. Sempre que eu clicar no número de ID da Planilha 1, ele mostrará automaticamente a Planilha 2 selecionando as células com os mesmos números de ID que cliquei na Planilha 1. A Planilha 2 pode ter duplicatas e deve selecionar os mesmos IDs. Se não houver duplicata, basta selecionar uma célula com o mesmo ID.

Planilha2

O que eu só sei é usar a função de link do Excel para ir para a Planilha 2 que mostra apenas a Planilha 2 inteira.

Folha 1 vinculada à folha 2

A ajuda é muito apreciada.

Tenho uma pergunta de acompanhamento para esta pergunta anterior que tive. Não incluí essa pergunta lá para evitar confusão.

Portanto, já tenho uma função Enviar completa e funcional que salva tudo, desde a Página1 (Planilha1) até a Página2 (Planilha2).

Agora, sempre que clicar em um número de ticket aleatório na Página2, gostaria que ele fosse copiado para a Página3 (Planilha3) com seus detalhes preenchidos automaticamente - Data, Hora, Ticket, Pontuação e respostas Sim/Não/NA.

Página 2

Usando a imagem da Página2 acima, se qualquer célula com número de ticket no intervalo C for clicada, toda a sua linha de valores será copiada para a Página3.

Por exemplo, quando clico no Ticket 7789 2024,

Values of Date, Time, Ticket will go to cells E3:E5 of Page 3
Value of Score will go to J3 of Page3
Values of Yes/No/NA answers from Range E:BC of Page2 will go to cells E7:57 of Page3

Será exibido assim quando eu clicar no número do ticket 7789 2024 da imagem Page2 acima:

Página3

O que comecei é este código colocado no módulo da planilha Page2 (para ser sincero, não sei como continuar):

Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Target As Range)

    
    Dim sh, sh2 As Worksheet
    Set sh = ThisWorkbook.Sheets("Page2")
    Set sh2 = ThisWorkbook.Sheets("Page3")
    
    
    If Selection.Count = 1 Then
        If Not Intersect(Target, sh.Range("C:C")) Is Nothing Then
            'Values of Date, Time, Ticket from Page2 will go to cells E3:E5 of Page 3
            'Value of Score from Page2 will go to J3 of Page3
            'Values of Yes/No/NA answers from Range E:BC of Page2 will go to cells E7:57 of Page3
        End If
    End If
End Sub

Sua ajuda é muito apreciada.

Eu tenho isso no meu código:

Dim cYear() As Variant

Não tenho certeza do que codificar a seguir. Deveria ser assim:

cYear = Array("2023","2024","2025")

ou

cYear = Array("2023,2024,2025")

ou

cYear = Array(2023, 2024, 2025)

Por favor, avise. Obrigado..

Tenho aqui um trecho de código para o evento de alteração do ComboBox4. Como você pode ver nos dados abaixo (formato de imagem excel), existe uma coluna para Tempo que tem meu formato preferido de “hh:mm:ss”. Estou tentando obter a soma da coluna tempo no ListBox (resultado mostrado no Label1 do Form). O resultado abaixo não está obtendo a soma correta.

Forma

Imagem de planilha do Excel (os espaços em branco têm uma finalidade)

Aqui estão os dados brutos da imagem acima:

Col. A         Col. B      Col. E       Col. G    Col. J           Col. L
YEAR      || NAME   || Total Time   || COLOR    || MONTH        || SHAPE
2023      || LINA   || 0:00:15      || GREEN    || AUGUST       || HEART
2023      || LINA   || 0:00:07      || GREEN    || SEPTEMBER    || CIRCLE
2024      || GARY   || 0:00:01      || GREEN    || SEPTEMBER    || DIAMOND
2024      || GARY   || 0:00:02      || GREEN    || SEPTEMBER    || RECTANGLE
2024      || GARY   || 0:00:15      || RED      || AUGUST       || OVAL
2023      || GARY   || 0:00:07      || RED      || AUGUST       || RECTANGLE
2023      || GARY   || 0:00:01      || GREEN    || AUGUST       || SQUARE
2024      || GARY   || 0:00:02      || GREEN    || SEPTEMBER    || STAR
2024      || TOM    || 0:00:15      || RED      || AUGUST       || HEART
2024      || TOM    || 0:00:07      || RED      || SEPTEMBER    || CIRCLE
2024      || TOM    || 0:00:01      || RED      || SEPTEMBER    || DIAMOND
2024      || TOM    || 0:00:02      || YELLOW   || SEPTEMBER    || OVAL
2024      || TOM    || 0:00:15      || YELLOW   || OCTOBER      || RECTANGLE
2024      || TOM    || 0:00:07      || YELLOW   || OCTOBER      || CIRCLE
2024      || TOM    || 0:00:01      || YELLOW   || OCTOBER      || SQUARE
2024      || TOM    || 0:00:02      || YELLOW   || OCTOBER      || STAR
2024      || TOM    || 0:00:15      || YELLOW   || OCTOBER      || STAR
2024      || TOM    || 0:00:07      || BLUE     || OCTOBER      || SQUARE

Aqui está o código do ComboBox4:

Option Explicit
Private Sub ComboBox4_Change()
    If Not ComboBox4.Value = "" Then
        Dim ws As Worksheet, rng As Range, count As Long, K As Long
        Dim arrData, arrList(), i As Long, j As Long
        Set ws = Worksheets("Sheet1")
        
        Dim countT As Date 'declared the variable here
        
        Set rng = ws.Range("A1:L" & ws.Cells(Rows.count, "B").End(xlUp).Row)
        arrData = rng.Value
        count = WorksheetFunction.CountIfs(rng.Columns(1), CStr(ComboBox2.Value), rng.Columns(2), ComboBox1.Value, rng.Columns(7), ComboBox3.Value, rng.Columns(10), ComboBox4.Value)
        ReDim arrList(1 To count + 1, 1 To UBound(arrData, 2))
        For j = 1 To UBound(arrData, 2)
            arrList(1, j) = arrData(1, j) 'header
        Next
        K = 1
                
        For i = 2 To UBound(arrData)
            If arrData(i, 2) = ComboBox1.Value And arrData(i, 1) = CStr(ComboBox2.Value) _
                And arrData(i, 7) = ComboBox3.Value And arrData(i, 10) = ComboBox4.Value Then
                K = K + 1
                
                countT = 0
                
                For j = 1 To UBound(arrData, 2)
                
                    countT = countT + arrData(i, 5) 'trying to get their total sum
                    
                    arrList(K, 5) = Format(arrData(i, 5), "hh:mm:ss")
                Next
                Label1.Caption = Format(CDate(countT), "hh:mm:ss") 'show total sum in this label in the form of hh:mm:ss
            End If
        Next
        With Me.ListBox1
            .ColumnHeads = False
            .ColumnWidths = "0,0,0,0,40,0,0,0,0,0,0,0"
            .ColumnCount = UBound(arrData, 2)
            .List = arrList
        End With
    End If
End Sub

Agradeço antecipadamente...

Eu tenho aqui ComboBoxes em cascata quando filtrados, serão exibidos corretamente no ListBox1. Abaixo estão meus dados da Planilha1 (não se importe como eles estão organizados, pois têm uma finalidade e adicionarei mais dados nessas células em branco):

Dados brutos da planilha 1:

Col. A    Col. B   Col. G    Col. J    Col. L
YEAR    || NAME || COLOR || MONTH    || SHAPE
2023    || LINA || GREEN || AUGUST   || HEART
2023    || LINA || GREEN || SEPTEMBER|| CIRCLE
2024    || GARY || GREEN || SEPTEMBER|| DIAMOND
2024    || GARY || RED   || AUGUST   || OVAL
2023    || GARY || RED   || AUGUST   || RECTANGLE
2023    || GARY || GREEN || AUGUST   || SQUARE
2024    || GARY || GREEN || SEPTEMBER|| STAR
2024    || TOM  || RED   || AUGUST   || HEART
2024    || TOM  || RED   || SEPTEMBER|| CIRCLE
2024    || TOM  || RED   || SEPTEMBER|| DIAMOND
2024    || TOM  || YELLOW|| SEPTEMBER|| OVAL
2024    || TOM  || YELLOW|| OCTOBER  || RECTANGLE
2024    || TOM  || BLUE  || OCTOBER  || SQUARE

Agora, meu desafio é que os ComboBoxes 2 a 5 não listam os dados esperados durante o filtro. Como você pode ver abaixo, filtrei desta forma, mas há um mês adicional adicionado no ComboBox 4:

Quando deveria ser apenas neste mês (quando filtrado manualmente na planilha):

Além disso, fiz outro filtro para outro nome abaixo, mas o ComboBox5 está mostrando todas as formas exclusivas em vez de apenas o Coração.

Resultado esperado para ComboBox5 (quando filtrado manualmente na planilha):

Este é o meu código para os ComboBoxes em cascata:

Option Explicit
Private Sub ComboBox4_Change()
''''''**************************** Different Tasks Not Equal to No Ticket
  If Not ComboBox4.Value = "" Then
    With Me.ComboBox5
        .Enabled = True
        .BackColor = &HFFFF&
        
        Dim ws As Worksheet
        Dim rcell As Range, Key
        Dim dic As Object: Set dic = CreateObject("Scripting.Dictionary")
        Set ws = Worksheets("Sheet1")
            
        .Clear
        .Value = vbNullString
        
            For Each rcell In ws.Range("B2", ws.Cells(Rows.count, "B").End(xlUp))
                    If rcell.Offset(0, 0) <> ComboBox1.Value And rcell.Offset(0, -1) <> ComboBox2.Value And rcell.Offset(0, 5) <> ComboBox3.Value And rcell.Offset(0, 8) <> ComboBox4.Value Then
                    Else
                        If Not dic.Exists(rcell.Offset(, 10).Value) Then
                            dic.Add rcell.Offset(, 10).Value, Nothing
                        End If
                    End If
            Next rcell
            For Each Key In dic
                Me.ComboBox5.AddItem Key
            Next
    End With
Else
     With Me.ComboBox5
     .Clear
    .Enabled = False
    .BackColor = &HFFFFFF
    End With
End If
End Sub
Private Sub ComboBox3_Change()
If Not ComboBox3.Value = "" Then
    With Me.ComboBox4
        .Enabled = True
        .BackColor = &HFFFF&
        
        Dim ws As Worksheet
        Dim rcell As Range, Key
        Dim dic As Object: Set dic = CreateObject("Scripting.Dictionary")
        Set ws = Worksheets("Sheet1")
            
        .Clear
        .Value = vbNullString
        
            For Each rcell In ws.Range("B2", ws.Cells(Rows.count, "B").End(xlUp))
                    If rcell.Offset(0, 0) <> ComboBox1.Value And rcell.Offset(0, -1) <> ComboBox2.Value And rcell.Offset(0, 5) <> ComboBox3.Value Then
                    Else
                        If Not dic.Exists(rcell.Offset(, 8).Value) Then
                            dic.Add rcell.Offset(, 8).Value, Nothing
                        End If
                    End If
            Next rcell
            For Each Key In dic
                Me.ComboBox4.AddItem Key
            Next
    End With
    Me.ComboBox5.Clear
Else
     With Me.ComboBox4
     .Clear
    .Enabled = False
    .BackColor = &HFFFFFF
    End With
    Me.ComboBox5.Clear
End If
End Sub

Private Sub ComboBox2_Change()
If Not ComboBox2.Value = "" Then
    With Me.ComboBox3
        .Enabled = True
        .BackColor = &HFFFF&
        
        Dim ws As Worksheet
        Dim rcell As Range, Key
        Dim dic As Object: Set dic = CreateObject("Scripting.Dictionary")
        Set ws = Worksheets("Sheet1")
            
        .Clear
        .Value = vbNullString
        
            For Each rcell In ws.Range("B2", ws.Cells(Rows.count, "B").End(xlUp))
                    If rcell.Offset(0, 0) <> ComboBox1.Value And rcell.Offset(0, -1) <> ComboBox2.Value Then
                    
                    Else
                        If Not dic.Exists(rcell.Offset(, 5).Value) Then
                            dic.Add rcell.Offset(, 5).Value, Nothing
                        End If
                    End If
               ' Next rYear
            Next rcell
            For Each Key In dic
                Me.ComboBox3.AddItem Key
            Next
    End With
        Me.ComboBox4.Clear
        Me.ComboBox5.Clear
Else
     With Me.ComboBox3
     .Clear
    .Enabled = False
    .BackColor = &HFFFFFF
    End With
    Me.ComboBox4.Clear
    Me.ComboBox5.Clear
End If

End Sub
Private Sub ComboBox1_Change() 'done
If Not ComboBox1.Value = "" Then
    With Me.ComboBox2
        .Enabled = True
        .BackColor = &HFFFF&
        
        Dim ws As Worksheet
        Dim rcell As Range, Key
        Dim dic As Object: Set dic = CreateObject("Scripting.Dictionary")
        Set ws = Worksheets("Sheet1")
            
        .Clear
        
            For Each rcell In ws.Range("B2", ws.Cells(Rows.count, "B").End(xlUp))
                    If rcell.Value = ComboBox1.Value Then
                        If Not dic.Exists(rcell.Offset(, -1).Value) Then
                            dic.Add rcell.Offset(, -1).Value, Nothing
                        End If
                    End If
            Next rcell
            For Each Key In dic
                Me.ComboBox2.AddItem Key
            Next
    End With
        Me.ComboBox3.Clear
        Me.ComboBox4.Clear
        Me.ComboBox5.Clear
Else
     With Me.ComboBox2
     .Clear
    .Enabled = False
    .BackColor = &HFFFFFF
    End With
    Me.ComboBox3.Clear
    Me.ComboBox4.Clear
    Me.ComboBox5.Clear

End If

End Sub

Private Sub UserForm_Initialize()
    
Dim ws As Worksheet
Dim rcell As Range
'dim dic as Object: set dic = createobject("Scripting.Dictionary")
Set ws = Worksheets("Sheet1")

ComboBox1.Clear

With CreateObject("scripting.dictionary")
For Each rcell In ws.Range("B2", ws.Cells(Rows.count, "B").End(xlUp))
If Not .Exists(rcell.Value) Then
.Add rcell.Value, Nothing
End If
Next rcell
ComboBox1.List = .Keys

End With
    With Me.ComboBox2
    .Enabled = False
    .BackColor = &HFFFFFF
    End With
    With Me.ComboBox3
    .Enabled = False
    .BackColor = &HFFFFFF
    End With
    With Me.ComboBox4
    .Enabled = False
    .BackColor = &HFFFFFF
    End With
    With Me.ComboBox5
    .Enabled = False
    .BackColor = &HFFFFFF
    End With
End Sub

O que poderia dar errado nos meus códigos ComboBoxes para não obter a lista correta conforme o esperado durante o filtro? E ainda não tenho um código para mostrar os dados filtrados no ListBox1. Minha saída desejada é mostrar as entradas filtradas com colunas completas (incluindo as colunas em branco, já que colocarei alguns dados nesses espaços em branco apenas para fins de exibição junto com as entradas filtradas) em ListBox1 durante a alteração do ComboBox5 como esta abaixo, exceto que deveria estar em ListBox1. Por favor ajude. Agradeço antecipadamente.

Tenho aqui um código derivado de uma resposta que exibe o listbox corretamente na data atual. Se eu tiver uma coluna B que armazena nomes de usuário diferentes, quero inserir isto no código:

Se o nome de usuário atual (Application.UserName) no formulário ativo for igual a um dos nomes na coluna B, filtre as entradas hoje apenas para esse nome de usuário

Saída atual:

A caixa de listagem é filtrada na data atual usando o código abaixo

Saída desejada

A mesma Listbox é filtrada na data atual e no nome de usuário atual usando o código abaixo com um código adicional para filtragem de nome de usuário

Atualizar

Estes são os dados brutos:

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

Imagem de dados brutos:

Código derivado atualizado incluindo a resposta de Taller abaixo:

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

Ele está obtendo o resultado para o nome de usuário declarado conforme a resposta (neste caso para McGrath), exceto que a data mudou para 12h00 e a hora tornou-se decimais no resultado:

Resultado Excel

Resultado da caixa de listagem

Agradecemos antecipadamente pela ajuda

Tenho aqui uma listbox que é filtrada pelo nome de uma pessoa. Quando um nome é escolhido em uma caixa de combinação, a caixa de listagem é preenchida corretamente. O que eu gostaria de conseguir é que quando a caixa de listagem for exibida, ela coloque as entradas de tempo em zeros (veja a Figura 3).

Figura 1 (Nome Escolhido 1)

Figura 2 (Nome Escolhido 2)

Codificado manualmente na planilha Excel:

Implementation                 ||  Arizona || New York  || Louisiana|| Michigan
Total Hours Worked (hh:mm:ss)  ||     0    ||    0      ||    0     ||    0
Average Hours (hh:mm:ss)       ||     0    ||    0      ||    0     ||    0

Figura 3

Esta é a saída desejada para o Nome Escolhido 1:

Este é o meu resultado desejado para o Nome Escolhido 2:

Este é o resultado que obtenho ao escolher o Nome 1.

Este é o resultado que obtenho ao escolher o Nome 2.

Este é o meu código para salvar a caixa de listagem na planilha:

        Dim sh As Worksheet

        Set sh = ThisWorkbook.Sheets("Sheet4")

        Dim n As Long



        For n = 1 To Me.ListBox2.ListCount - 1

        sh.Range("A" & Rows.Count).End(xlUp).ClearContents

        sh.Range("A" & Rows.Count).End(xlUp).Offset(1, 0) = Me.ListBox2.List(n, 0)

        sh.Range("A" & Rows.Count).End(xlUp).Offset(0, 1) = Me.ListBox2.List(n, 1)

        sh.Range("A" & Rows.Count).End(xlUp).Offset(0, 2) = Me.ListBox2.List(n, 2)

       

        Next n

Tenho aqui um código pronto para gráfico, mas irei usá-lo apenas quando o código para salvar entradas da caixa de listagem no Excel já estiver corrigido.

            'Dim CurrentFileName As String

            'CurrentFileName = ThisWorkbook.Path & "\current.gif"

              

            'Dim CurrentChart As Chart

            'Set CurrentChart = ThisWorkbook.Sheets("Sheet4").ChartObjects("Chart 1").Chart

            'CurrentChart.Export Filename:=CurrentFileName, FilterName:="GIF"

              

            'UserForm3.Image1.Picture = LoadPicture(CurrentFileName)

Por favor, diga-me onde estou errando. TY