Excel VBA 表单在列表框中显示带有时间计算的唯一条目

Question

我想请您帮助解决我的以下问题。我这里有两种不同的形式。用于保存条目的表格 1。为了保存条目，我已经有了代码。它已经开始工作了。表格 2 是显示 Excel 数据的表格，并以时间计算作为所需输出。请查看图片，因为它会有所帮助。

Excel Sheet1 中的数据：

Date      || Project ID || Implementation Area  || Start Time   || End Time     || Status
8/28/2023 || 1145544    || Arizona              || 8:00:03 AM   || 9:15:17 AM   || For Approval 1
8/28/2023 || 1157788    || Arizona              || 9:15:20 AM   || 12:00:19 PM  || For Approval 1
8/28/2023 ||LUNCH BREAK ||                      || 12:00:18 PM  || 1:00:00 PM   || LUNCH BREAK
8/29/2023 || 1145544    || Arizona              || 1:00:01 PM   || 3:00:00 PM   || For Approval 2
8/29/2023 || 1145544    || Arizona              || 3:30:07 PM   || 3:40:40 PM   || COMPLETED
8/30/2023 || 1157788    || Arizona              || 3:41:00 PM   || 3:50:00 PM   || For Approval 2
9/1/2023  || 1157788    || Arizona              || 4:00:00 PM   || 4:30:45 PM   || COMPLETED
9/2/2023  || 1233343    || New York             || 9:05:17 AM   || 11:30:20 AM  || For Approval 1
9/2/2023  ||LUNCH BREAK ||                      || 12:00:00 AM  || 1:00:00 PM   || LUNCH BREAK
9/2/2023  || 1233343    || New York             || 1:45:01 PM   || 2:45:30 PM   || For Approval 2
9/2/2023  || 1233343    || New York             || 3:00:00 AM   || 3:22:00 AM   || COMPLETED
9/2/2023  || 1422457    || Louisana             || 3:50:00 PM   || 4:12:00 PM   || For Approval 1
9/3/2023  || 1422457    || Louisana             || 10:18:03 AM  || 11:15:17 AM  || For Approval 2
9/4/2023  || 1422457    || Louisana             || 4:15:20 PM   || 4:35:19 PM   || COMPLETED

表格1

表格2

这是我的表格 2 代码

Private Sub UserForm_Initialize()
Dim colimplementationArea1 As Variant, colimplementationArea2 As Variant, colimplementationArea3 As Variant
Dim colStatus1 As Variant, colStatus2 As Variant, colStatus3 As Variant

Set Rng = Range("C:C") 'project id
Set rng1 = Range("D:D") 'implementation area
Set rng2 = Range("E:E") 'start time
Set rng3 = Range("F:F") 'end time
Set rng3 = Range("G:G") 'status

colimplementationArea1 = "Arizona"
colimplementationArea2 = "New York"
colimplementationArea3 = "Louisana"
colStatus1 = "For Approval 1"
colStatus2 = "For Approval 2"
colStatus3 = "COMPLETED"


'i lack codes for Listbox1 and Listbox2 that will display data from Excel Sheet1:

'--------Listbox1
'Unique Project ID     |    Area of Implementation     |    Total Hours Worked from Approval 1 to COMPLETED per Unique ID

'Calculation:
'***total hours worked will add the time of Start Time and End Time of For Approval 1 + Start Time and
' + End Time of For Approval 2 + Start 'Time and End Time of COMPLETED***



'--------Listbox2
'Unique Area of Implementation | Total Hours Worked using different Unique IDs containing same Area | Avearage Hours

'Calculation:
'***using Sheet1, we will be adding the total hours of the 2 Unique IDs 1145544 and 1157788 for Arizona from
'Start Time to End Time then divide it by 2 (since there are 2 unique ids)
'There's nothing to calculate for the rest of the Areas because they contain 1 unique ID only***


'Apologies... I really don't know where to start for the calculations of my listboxes
End Sub

Answer 1

在列表框中编码和输出结果似乎是一个相当复杂的问题，但这里有一种方法可以使其保持相对组织和足够灵活以进行更改。

我使用类模块和字典对象来组织数据并创建输出数组

类模块
按照注释中的指示重命名

'rename cProjectData
Option Explicit
Private pID As Variant
Private pDt As Date
Private pIArea As String
Private pStartTime As Date
Private pEndTime As Date
Private pStatus As String
Private pCol As Collection

Public Property Get ID() As Variant
    ID = pID
End Property
Public Property Let ID(value As Variant)
    pID = value
End Property

Public Property Get Dt() As Date
    Dt = pDt
End Property
Public Property Let Dt(value As Date)
    pDt = value
End Property

Public Property Get IArea() As String
    IArea = pIArea
End Property
Public Property Let IArea(value As String)
    pIArea = value
End Property

Public Property Get StartTime() As Date
    StartTime = pStartTime
End Property
Public Property Let StartTime(value As Date)
    pStartTime = value
End Property

Public Property Get EndTime() As Date
    EndTime = pEndTime
End Property
Public Property Let EndTime(value As Date)
    pEndTime = value
End Property

Public Property Get Status() As String
    Status = pStatus
End Property
Public Property Let Status(value As String)
    pStatus = value
End Property

Public Property Get TotHrs() As Date
    TotHrs = pTotHrs
End Property
Public Property Let TotHrs(value As Date)
    pTotHrs = value
End Property

Public Property Get Col() As Collection
    Set Col = pCol
End Property

Public Function addColItem(value)
    pCol.Add value
End Function

Private Sub Class_Initialize()
    Set pCol = New Collection
End Sub

用户表单模块
请注意，在此实现中不需要进行很多声明
请务必按照注释中的指示设置

Reference

'Add Reference to Microsoft Scripting Runtime
'   for early binding to Dictionary object

Option Explicit
    'should always be at the start of any VBA module
    'set Tools/Options/Editor/Code Settings/Require variable declaration
    'be sure to declare **ALL** variables
    
Private Sub UserForm_Initialize()

Dim TotalHours As Date
Dim I As Long, j As Long
Dim k, v
Dim sKey As String

'more descriptive names might be useful in debugging
'  and an array will both limit the appropriate ranges
'  and process much faster

  Dim vData As Variant

'since this code is in a sheet module, no need to
'  specifically reference this worksheet
vData = Range(Cells(2, 2), Cells(Rows.Count, 7).End(xlUp))

'Trim the strings
'may not be needed in your real data
    For I = 1 To UBound(vData, 1)
        For j = 1 To UBound(vData, 2)
            vData(I, j) = Trim(vData(I, j))
        Next j
    Next I

'Group data by Project Name and by Implementation area
Dim dProj As Dictionary
  Dim KeyDProj As Variant
    
'Create Class object to store the data
  Dim cProj As cProjectData

'iterate through the data and classify it
Set dProj = New Dictionary

For I = 1 To UBound(vData)
 If Not vData(I, 6) = "LUNCH BREAK" Then
    Set cProj = New cProjectData
    With cProj
        .Dt = vData(I, 1)
        .ID = vData(I, 2)
        .IArea = vData(I, 3)
        .StartTime = vData(I, 4)
        .EndTime = vData(I, 5)
        .Status = vData(I, 6)
    End With
    
    KeyDProj = cProj.ID
    
    If Not dProj.Exists(KeyDProj) Then
        cProj.addColItem cProj
        dProj.Add Key:=KeyDProj, Item:=cProj
    Else
        dProj(KeyDProj).addColItem cProj
    End If
    
 End If
Next I

'Access the dictionary and summarize the results
'for ListBox 1 into an array
    Dim vResL1 As Variant
ReDim vResL1(0 To dProj.Count, 1 To 3)

'Headers
    vResL1(0, 1) = "Project Name"
    vResL1(0, 2) = "Implementation Area"
    vResL1(0, 3) = "Total Hours"
I = 1
For Each k In dProj.Keys
    TotalHours = 0
    For Each v In dProj(k).Col
        TotalHours = TotalHours + v.EndTime - v.StartTime
        vResL1(I, 1) = v.ID
        vResL1(I, 2) = v.IArea
    Next v
    vResL1(I, 3) = TotalHours
    I = I + 1
Next k

'summarize vResL1 by averaging TotalHours
Dim dImplArea As Dictionary
Set dImplArea = New Dictionary
    dImplArea.CompareMode = TextCompare
    
For I = 1 To UBound(vResL1, 1)
    sKey = vResL1(I, 2)
    
    If Not dImplArea.Exists(sKey) Then
        dImplArea.Add Key:=sKey, Item:=Array(1, vResL1(I, 3))
    Else
        v = dImplArea(sKey)
        v(0) = v(0) + 1
        v(1) = v(1) + vResL1(I, 3)
        dImplArea(sKey) = v
    End If
Next I

Dim vResL2 As Variant
ReDim vResL2(0 To dImplArea.Count, 1 To 3)

'Headers
    vResL2(0, 1) = "Implementation Area"
    vResL2(0, 2) = "Total Hours Worked:"
    vResL2(0, 3) = "Average Hours:"
    
I = 1
    For Each v In dImplArea.Keys
        vResL2(I, 1) = v
        vResL2(I, 2) = dImplArea(v)(1)
        vResL2(I, 3) = CDate(dImplArea(v)(1) / dImplArea(v)(0))
        I = I + 1
    Next v
    
'write results to the listboxes
With Me.ListBox1
    .ColumnCount = 3
    .ColumnWidths = "75;110;100"
    
    .List = vResL1
End With

With Me.ListBox2
    .ColumnCount = 3
    .ColumnWidths = "110;100;75"
    .List = vResL2
End With

End Sub

数据输出