Results 1 to 5 of 5

20150405, 20:07 #1
 Join Date
 Mar 2015
 Posts
 15
 Thanks
 1
 Thanked 0 Times in 0 Posts
VBA Code to Count Consecutive Days Worked
I am trying to figure out if there is a method in Excel to warn me when an employee reaches 14 consecutive days worked as well as when he or she is going to reach 21 consecutive day worked based on consecutive days which are stored in column B and display the result in column M and in column N, display the date when an employee reached or will reach his/her 14 or 21 consecutive days worked. My main goal with this file is to develop a system that warms me before an employee reaches his 14 and 21 consecutive days worked in order to rotate with alternative shifts. As an example, I have attached a file that gets downloaded weekly from Kronos and its data gets populated in column A to G. I thought of using helper columns from K through N to display employees who meet the 14 and 21 consecutive day worked criteria, but I don’t know if this would be the best alternative. The VBA code that I am currently using almost accomplish the task, except for some add reason, it adds an extra day to some of the employees and does not show the date when the employee reached or will reach his 14 or 21 consecutive day worked.
I would appreciate greatly your ideas, comments, suggestions or improvement to the code.
Che
Code:Option Explicit Sub RunReport() Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Call Headers Call Employees Call LookupNames Call GetConsecutiveDays Call Sort Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True Range("K1").Select End Sub Private Function ConsecutiveDaysWorked(EmpNumber As Long, Data_Cells As Range) As Long Dim x As Long ConsecutiveDaysWorked = 1 x = Data_Cells.Rows.Count If x = 1 Then Exit Function For x = x To 2 Step 1 If Data_Cells(x, 2) <> Data_Cells(x  1, 2) Then If Data_Cells(x, 2)  1 = Data_Cells(x  1, 2) Then ConsecutiveDaysWorked = ConsecutiveDaysWorked + 1 Else Exit Function End If End If Next x End Function Private Sub Headers() Dim Headers Headers = Array("PersonID", "PersonName", "Consecutive Days Worked") ActiveSheet.Range("K1").Resize(1, 3).Value = Headers ActiveSheet.Range("K1:M1").Font.Bold = True End Sub Private Sub Employees() Dim r As Range, i As Long, o As Variant With CreateObject("Scripting.Dictionary") For Each r In Range("A2", Range("A1").End(xlDown)) If Not .Exists(r.Value) Then .Add r.Value, r.Value End If Next r o = Application.Transpose(Array(.Keys)) i = .Count ActiveSheet.Cells(2, 11).Resize(i).Value = o End With End Sub Private Sub LookupNames() Dim rngVlookup As String Dim lr1 As Long Dim lr2 As Long lr1 = Cells(Rows.Count, 1).End(xlUp).Row lr2 = Cells(Rows.Count, 11).End(xlUp).Row rngVlookup = "$A2:$E" & lr1 Range("L2:L" & lr2).Formula = "=VLOOKUP(K2," & rngVlookup & ",5,0)" End Sub Private Function GetEmployeeRange(EmployeeNumber) As Range Dim rngBeginning As Range Dim rngEnding As Range Dim rngToLookAt As Range Dim lr As Long lr = Cells(Rows.Count, 1).End(xlUp).Row With ActiveSheet.Range("A1:A" & lr) Set rngBeginning = .Find(What:=EmployeeNumber) Set rngEnding = .Find(What:=EmployeeNumber, SearchDirection:=xlPrevious) End With Set GetEmployeeRange = Range(rngBeginning, rngEnding) End Function Private Sub GetConsecutiveDays() Dim rngEmpNumbers As Range Dim EmpNumber As Long Dim r As Range Dim lr As Long Dim rngData As Range Dim cDaysWorked As Long lr = Cells(Rows.Count, 1).End(xlUp).Row Set rngEmpNumbers = Range("K2:K" & lr) For Each r In rngEmpNumbers.Rows EmpNumber = r.Value If r.Value = "" Then Exit For Set rngData = GetEmployeeRange(EmpNumber) cDaysWorked = ConsecutiveDaysWorked(EmpNumber, rngData) r.Offset(0, 2).Value = cDaysWorked Next r End Sub Private Sub Sort() Columns("K:M").EntireColumn.AutoFit ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("M2:M4989" _ ), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("L2:L4989" _ ), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal With ActiveWorkbook.Worksheets("Sheet1").Sort .SetRange Range("K1:M4989") .Header = xlYes .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With End Sub

20150405, 22:16 #2
 Join Date
 Mar 2004
 Location
 Manning, South Carolina
 Posts
 9,434
 Thanks
 372
 Thanked 1,457 Times in 1,326 Posts
CHE,
See if this works for you. I've added a couple of helper formula columns and a helper row (mostly to negate empty cell errors).
I also used an advanced filter to get the complete list of Unique PersonIDs. You'll note that all the work was done w/o VBA although if this works for you you could automate the extraction of PersonIDs and the copying of formulas to fill the chart. HTH
Test File: CHEKronos Data.xlsmMay the Forces of good computing be with you!
RG
PowerShell & VBA Rule!
My Systems: Desktop Specs
Laptop Specs

20150405, 23:17 #3
 Join Date
 Mar 2015
 Posts
 15
 Thanks
 1
 Thanked 0 Times in 0 Posts
Thank you very much Mr. RetiredGeek for time and help. I think this is a brilliant way of accomplishing this difficult task. The question that I have for you is what is the purpose of row 2 and the date on B2 (12/31/2013)? I can’t understand the logic of 12/31/2013?
I’ll try your file tomorrow and I’ll let you know how it behaves for me.
Again thank you very much for your dedication and help.
Regards,
Che

20150406, 08:31 #4
 Join Date
 Mar 2004
 Location
 Manning, South Carolina
 Posts
 9,434
 Thanks
 372
 Thanked 1,457 Times in 1,326 Posts
CHE,
Since the formulas in row 3 reference row 2 I had to put some dummy values in row 2. I just picked a date that was obviously less than any date you would be using and more than 1 day less. The need for this is to make the formulas copyable down the rows w/o a lot of logic to test for the first data row. HTHMay the Forces of good computing be with you!
RG
PowerShell & VBA Rule!
My Systems: Desktop Specs
Laptop Specs

20150406, 10:10 #5
 Join Date
 Mar 2004
 Location
 Manning, South Carolina
 Posts
 9,434
 Thanks
 372
 Thanked 1,457 Times in 1,326 Posts
CHE,
Here's a better version with a button to regenerate the list and all the formulas. Just press the button (ReGen List) in K1 after you have entered new data.
File: CHEKronos Data V2.xlsm
HTHMay the Forces of good computing be with you!
RG
PowerShell & VBA Rule!
My Systems: Desktop Specs
Laptop Specs