excelvbatimelistboxunique
Excel VBA Form Show Unique Entries with Time Calculation in Listbox
I would like to ask your help about my query below. I have here 2 different forms. Form 1 for saving entries. For saving entries, I already have code. It's already working. Form 2 is a form to display data from excel with time calculation as a desired output. Please see images as it could help.
Data in 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
Form 1
Form 2
This is my code for Form 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
Solution
This seems a rather complex problem to code and output the results in List Boxes, but here's one way to keep it relatively organized and flexible enough for changes to be made.
I use a Class Module and Dictionary objects to organize the data and create output arrays
Class Module
Rename as indicated in Comments
'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
User Form Module
Note that a lot of your declarations are not necessary in this implementation
Be sure to set the Reference as indicated in the comments
'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
vResL1(I, 3) = Format(vResL1(I, 3), "hh:mm:ss")
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) = Format(dImplArea(V)(1), "hh:mm:ss")
vResL2(I, 3) = Format(CDate(dImplArea(V)(1) / dImplArea(V)(0)), "hh:mm:ss")
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
Output from your Data
- How to make Colors Mixer in vba
- How to get HEX color value from cell color?
- SSIS: Insert multiple Excel files with same format but different file name to multiple database table destinations based on the Excel filename
- How to randomize Excel rows
- VLOOKUP Returns 0 even though there is a value in the line below the first result
- transpose a table with multiple values in excel
- Trying to late bind outlook to but getting type mismatch error after create object line
- Power Query Transform a Column based on Another Column
- Apply FILTER formula to array (and use filter criteria on specific column in the array)
- Bitly API call using VBA Excel Macro
- excel vba projects not closing
- In a standard MS Access SQL query output that does not have any aliases, how do I replace the full names by their "first-letters" aliases?
- Sigma or Summation function in Excel
- Problem getting the value from a cell using M in excel
- INDEX MATCH to also pull through notes
- Move formatted data in selection from Excel into Word tables
- Excel VBA function to remove letters at end of string
- Can't get all excel processes to stop when closing through Powershell
- Excel function to construct an array from values without VBA
- Alternative method to delete file with out having to add MS Scripting Runtime Reference
- Add new button to worksheet with Excel Add-in
- Apply outline border only to range of cells with openpyxl
- How to Separate Data with Inconsistent Patterns into a Structured Format in Excel
- Excel - Aggregate dynamically values in a Table using array formulas (MAP, BYROW, CHOOSECOLS, TEXTJOIN, LAMBDA, FILTER, HSTACK) in a single Cell
- How to reference the current User\Desktop location in VBA
- Powerpoint chart to excel relative link
- EXCEL: How do I return multiple columns using XLOOKUP, when the lookup_value is a range?
- VBA: How to Loop IF Statement through a Cell and Chart Series
- Incorporating Checkbox to lines of code rather than Cell value
- How do I remove a character from a column of data in Excel