由于我是 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)
请告诉我哪里出错了。泰