Results 1 to 5 of 5
  1. #1
    New Lounger
    Join Date
    Mar 2015
    Posts
    15
    Thanks
    1
    Thanked 0 Times in 0 Posts

    Question 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
    Attached Files Attached Files

  2. #2
    Super Moderator RetiredGeek's Avatar
    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: CHE-Kronos Data.xlsm
    May the Forces of good computing be with you!

    RG

    PowerShell & VBA Rule!

    My Systems: Desktop Specs
    Laptop Specs

  3. #3
    New Lounger
    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

  4. #4
    Super Moderator RetiredGeek's Avatar
    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. HTH
    May the Forces of good computing be with you!

    RG

    PowerShell & VBA Rule!

    My Systems: Desktop Specs
    Laptop Specs

  5. #5
    Super Moderator RetiredGeek's Avatar
    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: CHE-Kronos Data V2.xlsm

    HTH
    May the Forces of good computing be with you!

    RG

    PowerShell & VBA Rule!

    My Systems: Desktop Specs
    Laptop Specs

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •