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:
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