Shiela's questions

我这里有一个列表框，可以与下面的代码一起正常工作。

列表框1

更新了整个代码：

Option Explicit
Dim bInit As Boolean ' ** module-scoped variable

Private Sub UserForm_Initialize()
    bInit = True  ' ** set UserForm_Initialize mode **from Taller
    clearAll
    Me.cmbName.Value = "Nory"
    Dim ws As Worksheet: Set ws = Worksheets("Sheet1")
    Dim i As Long
    Dim arr: arr = ws.Range("B1").CurrentRegion.Value
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")

    For i = 2 To UBound(arr)
        dict(arr(i, 2)) = arr(i, 1)
    Next
   ' ***
     If dict.exists(Me.cmbName.Value) Then
        Me.cmbTeam.Value = dict(Me.cmbName.Value)
        If Not cmbTeam.Value = "" And Not cmbDate.Value = "" And Not cmbName.Value = "" Then
            Team
            forListBoxUpdate 'calling forListBoxUpdate
            forDateCombobox 'filling in date dropdowns
            forNamesCombobox 'filling in names combobox as long as 3 comboboxes are not blank
        Else
            Team 'calling Team dropdowns in case team is blank or default cmbName value has no team
            cmbDate.Value = ""
            cmbName.Value = ""
        End If
    Else
            Team 'calling Team dropdowns in case team is blank or default cmbName value has no team
            cmbDate.Value = ""
            cmbName.Value = ""
    End If
    bInit = False  ' ** reset **from Taller
End Sub

Private Sub cmbDate_Change()
    If Not cmbTeam = "" And Not cmbName = "" Then
        forListBoxUpdate 'calling to show info if team and name not blank
        forNamesCombobox 'filling in cmbname dropdowns
    Else
        cmbDate.Clear 'if cmbteam and cmbname blank, cmdate should also be blank
    End If
End Sub

Private Sub cmbName_Change()
    forListBoxUpdate
End Sub

Private Sub cmbTeam_Change()
    cmbDate.Value = ""
    'cmbName.Value = "" 'issue, during initialize, default cmbname is removed.
    clearAll 'used this instead
    forDateCombobox 'fills in date dropdowns
End Sub



Sub forListBoxUpdate() 'to show info from sheets and to be called after the 3 comboboxes are filled
    Dim ws As Worksheet, colList As Collection
    Dim arrData, arrList, i As Long, j As Long
    
    Set colList = New Collection
    Set ws = Worksheets("Sheet2")
    arrData = ws.Range("A1:C" & ws.Cells(ws.Rows.count, "A").End(xlUp).Row)
    
        For i = 2 To UBound(arrData)
            If Format(arrData(i, 1), "mmmm yyyy") = Me.cmbDate.Value And arrData(i, 3) = Me.cmbName.Value Then
                colList.Add i, CStr(i)
            End If
    Next

    ReDim arrList(1 To colList.count + 1, 1 To UBound(arrData))
    For j = 1 To 3
        arrList(1, j) = arrData(1, j) ' header
        For i = 1 To colList.count
                arrList(i + 1, j) = arrData(colList(i), j)
        Next
    Next

    With Me.ListBox1
        .Clear
        .ColumnCount = UBound(arrData, 2)
        .list = arrList
    End With
    
    
    labelCount.Caption = ListBox1.ListCount - 1
End Sub

Sub clearAll() 'to clear comboboxes except teams
    If Not bInit Then cmbName.Value = ""  ' ** doesn't run when calling from UserForm_Initialize **from Taller
    cmbDate.Clear
    cmbName.Clear
    'cmbName.Value = ""
    ListBox1.Clear
End Sub

Sub Team() 'for adding the teams dropdown in cmbTeam
    clearAll
    Dim ws As Worksheet, _
        Dic As Object, _
        rCell As Range, _
        Key
    
    Set ws = Worksheets("Sheet1")
    Set Dic = CreateObject("Scripting.Dictionary")
    
    
    For Each rCell In ws.Range("A2", ws.Cells(Rows.count, "A").End(xlUp))
            If Not Dic.exists(rCell.Value) And Not rCell = "" Then
                Dic.Add rCell.Value, Nothing
            End If
    Next rCell
    
    For Each Key In Dic
        cmbTeam.AddItem Key
    Next
End Sub

Sub forNamesCombobox() 'for adding the names dropdown in cmbName
Dim ws As Worksheet, _
    Dic As Object, _
    rCell As Range, _
    Key

Set ws = Worksheets("Sheet1")
Set Dic = CreateObject("Scripting.Dictionary")


For Each rCell In ws.Range("B2", ws.Cells(Rows.count, "B").End(xlUp))
        If Not Dic.exists(rCell.Value) And rCell.Offset(0, -1) = cmbTeam.Value Then
            Dic.Add rCell.Value, Nothing
        End If
Next rCell

For Each Key In Dic
    cmbName.AddItem Key
Next
End Sub

Sub forDateCombobox() 'for adding the date dropdown in cmbDate
            Dim date1 As Variant
            Dim date2 As Variant
            date1 = Format(Now, "mmmm yyyy")
            date2 = Format(DateAdd("m", -1, CDate(date1)), "mmmm yyyy")
            
            With cmbDate
            .Clear
            .AddItem Format(date2, "mmmm yyyy")
            .AddItem Format(date1, "mmmm yyyy")
            .Value = Format(date1, "mmmm yyyy")
            End With
            
End Sub

工作表1

工作表2

现在，在团队组合框的更改事件期间，我希望清除名称组合框（“Nory”或任何值cmbName都应被删除并消失）。

从上面的代码中，团队变更事件片段是：

Private Sub cmbTeam_Change()
    cmbDate.Value = ""
    'cmbName.Value = "" 'issue, during initialize, default cmbname is removed.
    clearAll 'used this instead
    forDateCombobox 'fills in date dropdowns
End Sub

Sub clearAll() 'to clear comboboxes except teams
    If Not bInit Then cmbName.Value = ""  ' ** doesn't run when calling from UserForm_Initialize **from Taller
    cmbDate.Clear
    cmbName.Clear
    'cmbName.Value = ""
    ListBox1.Clear
End Sub

即使我将在初始化期间插入cmbName.Value = ""到 sub 中clearAll，"Nory"也会被删除，但我不希望它在初始化时被删除。

如何修复上述代码，在初始化期间，“Nory”将保留，团队和日期也将保留，而当团队发生变化时，日期和姓名组合框将为空白。

非常感谢您的帮助。

工作表1

初始化过程中出错：

如果团队成员在第 2 列匹配，则应修复以下代码以获取 Me.cmbTeam.Value（组合框）中填充的准确团队名称。

Private Sub UserForm_Initialize()
    Me.cmbDev.Value = "Nory"

    Dim ws As Worksheet: Set ws = Worksheets("Sheet1")
    Dim i As Long
    Dim arr: arr = ws.Range("B1").CurrentRegion.Value
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    Dim teamName As Variant

    For i = 2 To UBound(arr)
        dict(arr(i, 2)) = Empty
    Next
   ' ***
   
    If dict.exists(Me.cmbDev.Value) Then
        teamName = Application.VLookup(Me.cmbDev.Value, ws.Range("B1").CurrentRegion.Value, 1, False)
        Me.cmbTeam.Value = teamName 'should get a result of George
    Else
        Me.cmbDev.Value = ""
        Me.cmbTeam.Value = ""
    End If

End Sub

我这里有 2 张表。一张表用于存放主要数据。另一张表用于存放“名队”条目。

Sheet1（故意留空——如果有空白也可以查看结果）

工作表2

列表框：

我想选择来自 Sheet2 的团队。下面有一段代码，但会出现“类型不匹配”的错误。

在 ComboBox 更改期间调用 showList：

Sub showList()
    Dim ws As Worksheet, colList As Collection
    Dim arrData, arrList, i As Long, j As Long
    Dim targetTeam As Variant
    ' *** 
    Dim ws2 As Worksheet: Set ws2 = Worksheets("Sheet2")
    Dim arr: arr = ws2.Range("B1").CurrentRegion.Value
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    For i = 2 To UBound(arr)
        dict(arr(i, 2)) = Empty
    Next
   ' ***

    Set colList = New Collection
    Set ws = Worksheets("Sheet1")
    arrData = ws.Range("A1:E" & ws.Cells(ws.Rows.count, "A").End(xlUp).Row)
    For i = 2 To UBound(arrData)
            targetTeam = Application.VLookup((arrData(i, 2)), ws2.Range("B1").CurrentRegion.Value, -1, False)
                If dict.exists(arrData(i, 1)) And cmbTeam = targetTeam Then
                    colList.Add i, CStr(i)
                End If

    Next
    ReDim arrList(1 To colList.count + 1, 1 To UBound(arrData))
    For j = 1 To 5
        arrList(1, j) = arrData(1, j) ' header
        arrList(1, 4) = "Date Added Duration"
        arrList(1, 5) = "Date Modified Duration"
        For i = 1 To colList.count
                arrList(i + 1, j) = arrData(colList(i), j)
                    Dim dateA As Variant
                    Dim dateB As Variant
                    Dim dateC As Variant
                    Dim difference1 As Long
                    Dim difference2 As Long
                
                ' Assign values to the dates
                dateA = arrList(i + 1, 2)
                dateB = arrList(i + 1, 3)
                dateC = Format(Now, "m/d/yyyy")
                
                ' Calculate the difference in days
                difference1 = DateDiff("d", dateA, dateC) 'date today minus date added
                
                If Not dateA = "" Then
                    If difference1 > 1 Then
                    arrList(i + 1, 4) = difference1 & " days"
                    Else
                    arrList(i + 1, 4) = difference1 & " day"
                    End If
                Else
                    arrList(i + 1, 4) = "Missing"
                End If
                
                difference2 = DateDiff("d", dateB, dateC) 'date today minus date modified
                
                If Not dateB = "" Then
                    If difference2 > 1 Then
                    arrList(i + 1, 5) = difference2 & " days"
                    Else
                    arrList(i + 1, 5) = difference2 & " day"
                    End If
                Else
                    arrList(i + 1, 5) = "Missing"
                End If
        Next
    Next
    With Me.ListBox1
        .Clear
        .ColumnCount = UBound(arrData, 2)
        .list = arrList
    End With
End Sub

类型不匹配错误

期望：

我这里有另一个表单，在初始化期间显示 Sheet1 的数据。当有 Listbox 项目选择或 Listbox afterupdate 事件时，列表框会从 Sheet2 返回文本字段中选定数字（以字母 D 表示）的值：

工作表1

工作表2

列表框1

Private Sub ListBox1_AfterUpdate()
    Me.txtSheet1Digits.Value = ""
    Me.txtSheet1Date1.Value = ""
    Me.txtSheet1Date2.Value = ""
    Me.txtSheet1Version.Value = ""
    Me.txtSheet1Digits = ListBox1.Column(0)
    Me.txtSheet1Date1 = ListBox1.Column(1)
    Me.txtSheet1Date2 = ListBox1.Column(2)
    Me.txtSheet1Version = ListBox1.Column(3)
Matches
End Sub

上一篇文章中使用的代码片段：

Sub Matches()
    Dim ws2 As Worksheet: Set ws2 = Worksheets("Sheet2")
    Dim i As Long
    Dim arr: arr = ws2.Range("A1").CurrentRegion.Value
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    Dim targetDate As Variant
    Dim targetVersion As Variant
    For i = 2 To UBound(arr)
        dict(arr(i, 1)) = Empty
    Next

    If dict.exists(Me.txtSheet1Digits.Value) Then
        targetDate = Application.VLookup(Me.txtSheet1Digits.Value, ws2.Range("B1").CurrentRegion.Value, 3, False)
        targetVersion = Application.VLookup(Me.txtSheet1Digits.Value, ws2.Range("B1").CurrentRegion.Value, 4, False)
        Me.txtSheet2Date = targetDate
        Me.txtSheet2Version = targetVersion
    End If
            If Not Me.txtSheet1Date1 = Me.txtSheet2Date Or _
            Not Me.txtSheet1Version = Me.txtSheet2Version Then
            labelSheet1Date1.ForeColor = vbRed
            txtSheet1Date1.ForeColor = vbRed
            
            labelSheet1Date2.ForeColor = vbRed
            txtSheet1Date2.ForeColor = vbRed
            
            labelSheet2Date.ForeColor = vbRed
            txtSheet2Date.ForeColor = vbRed
            
            labelSheet1Version.ForeColor = vbRed
            txtSheet1Version.ForeColor = vbRed
            
            labelSheet2Version.ForeColor = vbRed
            txtSheet2Version.ForeColor = vbRed
            Else
            labelSheet1Date1.ForeColor = vbBlack
            txtSheet1Date1.ForeColor = vbBlack
            
            labelSheet1Date2.ForeColor = vbBlack
            txtSheet1Date2.ForeColor = vbBlack
            
            labelSheet2Date.ForeColor = vbBlack
            txtSheet2Date.ForeColor = vbBlack
            
            labelSheet1Version.ForeColor = vbBlack
            txtSheet1Version.ForeColor = vbBlack
            
            labelSheet2Version.ForeColor = vbBlack
            txtSheet2Version.ForeColor = vbBlack
            End If   
End Sub

我只是想知道以下错误可能是什么：

当我单击列表框中的第一个项目时，它会读取第一个 If 条件，而 Sheet2 中没有任何匹配项，这是正确的，并将空白返回到两个文本字段。接下来，它读取第二个条件，此时所有条件都变为红色 - 正确。

当我单击列表框的第二项时，读数相同，并且现在转到第二个 If 条件的其他条件，因此它全是黑色 - 正确。

现在，当我再次单击返回到第一个项目时，它会读取相同的模式，但不会再向两个文本字段返回空白。带有箭头的两个文本字段继续具有先前选定项目的值 - 错误。它应该返回空白。

这里有一张动态表，我只想显示到列表框中，A 到 F 列，其中 A 列/名称不等于空/空单元格。

我在初始化期间尝试了以下操作：

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

但是我遇到了subscript out of range错误。我还尝试向名称为“Mark”的单元格添加实际值#VALUE!，但遇到了同样的错误。（对于带有 #VALUE! 的单元格 - 它具有默认公式并且有用途）。还尝试了上述代码，但遇到了同样的错误：

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

我很感谢你的帮助。

我这里有原始数据。

Column B = Score- 来自用户的动态

Column C = Complexity (from users) and Column D = Points有固定表格。在下图中，用户输入空白/无复杂性。

图片 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).该列的格式为百分比。

Formula:
=(B2+D2)/5

Column F: Total without Points is based on Score (B) divided by 5 (highest complexity).该列的格式为百分比。

Formula:
=B2/5

上述所有公式均应用于各个列。现在，由于应用于 F 列的公式，我得到了单元格 F4 的 100.00%。请参见图 1。

如何为此列设置公式，如果其左侧单元格有错误值，它也会显示错误值，但仍会为使用 (=B2/5) 的所有其他单元格提供结果。

期望：

图片2

我很感谢你的帮助。

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

这里有一个带有数据表的子表单，我想在弹出视图中显示它。

如果“弹出”为“否”，则会显示整个页面。

如果弹出为是，则仅显示以下内容：

这些是我的属性：

我尝试将“自动调整大小”设置为“否”，但发生了同样的事情。

我应该在属性中设置什么以便至少它会自动显示以下内容：

弹出窗口

由于我是 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)

请告诉我哪里出错了。泰