Shiela's questions

由于我是 Access VBA 新手，请耐心等待。

我在 Form2 中有一个文本框，其名称txtEID和Employee ID值是从另一个表单传递过来的。

我还有一个名为的示例文本框，txtFullName它应该从表中自动填充人员姓名，其中表tblEmployees字段等于。EmployeeNameForm2.txtEID.valueEIDtblEmployees

我不知道如何在文本框中实现自动填充，但为了进行试用，我尝试在 ComboBox 中使用其 Rowsource 属性中的以下这一行：

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

它在组合框中显示所需的值（基于 txtEID 的 EID 的人名），但仅作为下拉列表。

如何根据中显示的 EID 将文本框的值设置txtFullName为表中的人名txtEID。我也不知道如何在txtFullName“控件来源”属性中进行设置。

这个问题困扰了我 6 个小时。非常感谢你的想法。

我是 Access 新手，下面有一段代码，用来将当前月份插入到一个表中，该表是我电脑中的当前日期减去 1 小时的结果：

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

我也尝试过这个：

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

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

对于这两个代码，我都收到此错误：

我只是从下面的工作代码中衍生出上述代码：

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

可能缺少什么？提前致谢。

这里有一个组合框，它从表格的日期列中获取值。它看起来是这样的：

有什么方法可以将组合框的日期列表转换为如下所示的不同月份？

我从它的答案中查看了这种方法，但这是使用 Excel 而我在使用 Access，并且对 Access 还不熟悉。

非常感谢您的帮助。提前致谢。

使用以前的文章，我添加了：

• 新列为名称和日期
• 新增 6 个标签（丹的每日和每月计数、丽莎的每日和每月计数、每日总计数和每月计数）
• 新建列表框2

我遇到一个问题，在 Listbox1 的结果是今天的输入（每日）而 Listbox2 是当月的输入（每月）的情况下，如何插入日期过滤条件。

这是来自 Excel Sheet1 的原始数据：

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

这是得出的代码：

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

这是所需的输出：

如何根据每日和每月日期过滤器获取列表框以及标签中的计数？

我这里有表 1，其中有我手动输入的 ID 号。

表1

我想用这个 ID 号做的是链接到工作表 2，选择相同的 ID 号。每当我单击工作表 1 的 ID 编号时，它会自动显示工作表 2 选择与我在工作表 1 上单击的相同 ID 编号的单元格。工作表 2 可能有重复项，它应该选择相同的 ID。如果没有重复项，那么它应该只选择具有相同 ID 的一个单元格。

表2

我只知道使用Excel的链接功能转到Sheet 2，它只显示整个Sheet 2。

表 1 链接到表 2

非常感谢您的帮助。

对于我之前提出的问题，我有一个后续问题。为了避免混淆，我没有包含这个问题。

所以我已经有了一个完整的工作提交功能，可以保存从第 1 页 (Sheet1) 到第 2 页 (Sheet2) 的所有内容。

现在，每当我单击第 2 页中的随机票号时，我都希望将其复制到第 3 页（Sheet3），并自动填充其详细信息 - 日期、时间、票证、分数和是/否/NA 答案。

第2页

使用上面第 2 页的图像，如果单击范围 C 中票号的任何单元格，它会将其整行值复制到第 3 页。

例如，当我点击 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

当我点击上面图像第2页的票号7789 2024时，它会显示如下：

第3页

我开始的是将此代码放入 Page2 工作表模块中（说实话，我不知道如何继续它）：

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

非常感谢您的帮助。

我的代码中有这个：

Dim cYear() As Variant

我不太确定接下来要编码什么。应该是这样的：

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

或者

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

或者

cYear = Array(2023, 2024, 2025)

请指教。谢谢..

我这里有 ComboBox4 更改事件的代码片段。正如您在下面的数据（Excel 图像形式）中看到的，有一个时间列，其格式为我首选的“hh:mm:ss”。我试图获取 ListBox 中时间列的总和（结果显示在表单的 Label1 中）。下面的结果没有得到正确的总和。

形式

Excel 工作表图像（空白有目的）

这是上图的原始数据：

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

这是 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

先感谢您...

我这里有级联 ComboBox，过滤后将在 ListBox1 中正确显示。下面是我的 Sheet1 数据（请不要介意它们的排列方式，因为它们有目的，我将在这些空白单元格上添加更多数据）：

Sheet1原始数据：

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

现在我的挑战是，组合框 2-5 在过滤期间没有列出预期数据。正如您在下面看到的，我以这种方式过滤了它，但在 ComboBox 4 中添加了一个额外的月份：

何时应该仅在本月（在工作表中手动过滤时）：

另外，我为下面的另一个名称做了另一个过滤器，但 ComboBox5 显示了所有独特的形状，而不仅仅是心形。

ComboBox5 的预期结果（在工作表中手动过滤时）：

这是我的级联组合框代码：

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

我的 ComboBoxes 代码中可能会出现什么问题，导致在过滤过程中未按预期获得正确的列表？我还没有在 ListBox1 中显示过滤数据的代码。我想要的输出是在 ComboBox5 更改期间在 ListBox1 中显示带有完整列的过滤条目（包括空白列，因为我将一些数据放入这些空白中以仅与过滤条目一起显示），就像下面的这个一样，只是它应该位于 ListBox1 中。请帮忙。先感谢您。

我这里有一个代码，源自在当前日期正确显示列表框的答案。如果我有一个存储不同用户名的 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结果

列表框结果

预先感谢您的帮助

我这里有一个按人名过滤的列表框。当从组合框中选择名称时，列表框将正确填充。我想要实现的是，当显示列表框时，它应该将时间条目放在零中（参见图 3）。

图 1（选择名称 1）

图 2（选择名称 2）

在 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

图3

这是我想要的“所选名称 1”的输出：

这是我对 Chosen Name 2 的期望结果：

这是我选择名称 1 时得到的结果。

这是我选择名称 2 时得到的结果。

这是我将列表框保存到工作表的代码：

        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

我这里有一个图形就绪代码，但当用于将列表框条目保存到 Excel 的代码已经修复时，我只会使用它。

            '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)

请告诉我哪里出错了。泰