Results 1 to 18 of 18

Thread: [RESOLVED] If employee has multiple rows for same period - VBA (EXCEL)

  1. #1

    Thread Starter
    Lively Member
    Join Date
    Feb 2012
    Location
    Manchester, UK
    Posts
    90

    Resolved [RESOLVED] If employee has multiple rows for same period - VBA (EXCEL)

    Hi All,


    Thanks to the help of two forum members TntinMN and vbfbryce for getting me to this point, it has saved me weeks of work in the future!

    So i thought I would post the next part of my work that is done manually so see if this is a possibility.

    I have the attached data

    What I want to do is copy data to a new sheet, each person on this NEW sheet will only have ONE row for each period.

    Rules:
    - If the employee has only ONE record for a period ("Pay Date from - Pay Date to") then
    -move data from ORIGINAL DATA columns A to E to the NEW SHEET columns A to E

    -If the employee has multiple records for a period (""Pay Date from - Pay Date to") then...
    -On the NEW SHEET the "Full time ANNUAL salary" (Col B) will be:-
    A total of "ANNUAL part-time salary" (col G) for the multiple records DIVIDED by the total % of "Percentage Worked"
    e.g Rows 3 and 4 of sample data - £2,975.54/24% = £12,398.13 <<-- This will be the "Full time ANNUAL salary" on the NEW SHEET
    -Monthly earnings will always be £1
    -Column F on the NEW SHEET will a total of "Days Excluded" (col H)
    The only rows on the NEW SHEET that will have data in column F will be those that had multiple rows on the original data.


    Hope I have explained this well enough.

    Thanks in advance.

    Test Data (concat).zip

  2. #2
    PowerPoster
    Join Date
    Oct 2008
    Location
    Midwest Region, United States
    Posts
    3,574

    Re: If employee has multiple rows for same period - VBA (EXCEL)

    I added a sheet and named it "NEW" and then used this code:

    Code:
    Sub copyToNew()
        Dim wb As Workbook
        Dim wsTest As Worksheet
        Dim wsNew As Worksheet
        Dim lr As Long
        Dim wr As Long
        Dim j As Long
        Dim k As Long
        Dim m As Integer
        Dim n As Integer
        Dim rngSort As Range
        Dim rngKey1 As Range
        Dim rngKey2 As Range
        Dim emps() As String
        Dim counter As Long
        Dim empStart As Long
        Dim empEnd As Long
        Dim writeRow As Long
        Dim sumSal As Long
        Dim sumPer As Double
        Dim ftaNew As Double
        
        Set wb = ActiveWorkbook
        Set wsTest = wb.Worksheets("TESTING")
        Set wsNew = wb.Worksheets("NEW")
        
        lr = wsTest.Range("a" & Rows.Count).End(xlUp).Row
        
        For j = 2 To lr
            If wsTest.Range("a" & j).Value <> wsTest.Range("a" & j - 1).Value Then
                ReDim Preserve emps(counter)
                emps(counter) = wsTest.Range("a" & j).Value
                counter = counter + 1
            End If
        Next j
        
        
        Set rngSort = wsTest.Range("a1:h" & lr)
        Set rngKey1 = wsTest.Range("a2:a" & lr)
        Set rngKey2 = wsTest.Range("d2:d" & lr)
        
        With wsTest.Sort
            .SortFields.Clear
            .SortFields.Add Key:=rngKey1
            .SortFields.Add Key:=rngKey2
            .SetRange rngSort
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        
        empStart = 2
        
        With wsTest
            For j = 0 To UBound(emps)
                For k = empStart + 1 To lr
                    If .Range("d" & k).Value <> .Range("d" & k - 1).Value Then
                        empEnd = k - 1
                        writeRow = wsNew.Range("a" & Rows.Count).End(xlUp).Row + 1
                        If empStart = empEnd Then
                            For m = 1 To 5
                                wsNew.Cells(writeRow, m).Value = wsTest.Cells(k - 1, m).Value
                            Next m
                        Else
                            
                            sumSal = 0
                            sumPer = 0
                            For n = empStart To empEnd
                                sumSal = sumSal + .Range("g" & n).Value
                                sumPer = sumPer + .Range("f" & n).Value
                            Next n
                            ftaNew = sumSal / sumPer
                            wsNew.Range("a" & writeRow).Value = wsTest.Range("a" & empStart).Value
                            wsNew.Range("b" & writeRow).Value = ftaNew
                            wsNew.Range("c" & writeRow).Value = 1
                            wsNew.Range("d" & writeRow).Value = wsTest.Range("d" & empStart).Value
                            wsNew.Range("e" & writeRow).Value = wsTest.Range("e" & empEnd).Value
                            wsNew.Range("f" & writeRow).Value = wsTest.Range("h" & empStart).Value
                        End If
                        empStart = empEnd + 1
                    Else
                        'else move on
                    End If
                    
                Next k
            Next j
            
        End With
    End Sub

  3. #3
    PowerPoster
    Join Date
    Oct 2008
    Location
    Midwest Region, United States
    Posts
    3,574

    Re: If employee has multiple rows for same period - VBA (EXCEL)

    One more try:

    Code:
    Sub copyToNew()
        Dim wb As Workbook
        Dim wsTest As Worksheet
        Dim wsNew As Worksheet
        Dim lr As Long
        Dim wr As Long
        Dim j As Long
        Dim k As Long
        Dim m As Integer
        Dim n As Integer
        Dim rngSort As Range
        Dim rngKey1 As Range
        Dim rngKey2 As Range
        Dim emps() As String
        Dim counter As Long
        Dim empStart As Long
        Dim empEnd As Long
        Dim writeRow As Long
        Dim sumSal As Long
        Dim sumPer As Double
        Dim ftaNew As Double
        
        Set wb = ActiveWorkbook
        Set wsTest = wb.Worksheets("TESTING")
        Set wsNew = wb.Worksheets("NEW")
        
        lr = wsTest.Range("a" & Rows.Count).End(xlUp).Row
        
        For j = 2 To lr
            If wsTest.Range("a" & j).Value <> wsTest.Range("a" & j - 1).Value Then
                ReDim Preserve emps(counter)
                emps(counter) = wsTest.Range("a" & j).Value
                counter = counter + 1
            End If
        Next j
        
        
        Set rngSort = wsTest.Range("a1:h" & lr)
        Set rngKey1 = wsTest.Range("a2:a" & lr)
        Set rngKey2 = wsTest.Range("d2:d" & lr)
        
        With wsTest.Sort
            .SortFields.Clear
            .SortFields.Add Key:=rngKey1
            .SortFields.Add Key:=rngKey2
            .SetRange rngSort
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        
        empStart = 2
        
        With wsTest
            For j = 0 To UBound(emps)
                For k = empStart + 1 To lr
                    If .Range("d" & k).Value <> .Range("d" & k - 1).Value Then
                        empEnd = k - 1
                        writeRow = wsNew.Range("a" & Rows.Count).End(xlUp).Row + 1
                        If empStart = empEnd Then
                            For m = 1 To 5
                                wsNew.Cells(writeRow, m).Value = wsTest.Cells(k - 1, m).Value
                            Next m
                        Else
                            
                            sumSal = 0
                            sumPer = 0
                            For n = empStart To empEnd
                                sumSal = sumSal + .Range("g" & n).Value
                                sumPer = sumPer + .Range("f" & n).Value
                            Next n
                            ftaNew = sumSal / sumPer
                            wsNew.Range("a" & writeRow).Value = wsTest.Range("a" & empStart).Value
                            wsNew.Range("b" & writeRow).Value = ftaNew
                            wsNew.Range("c" & writeRow).Value = 1
                            wsNew.Range("d" & writeRow).Value = wsTest.Range("d" & empStart).Value
                            wsNew.Range("e" & writeRow).Value = wsTest.Range("e" & empEnd).Value
                            wsNew.Range("f" & writeRow).Value = wsTest.Range("h" & empStart).Value
                        End If
                        empStart = empEnd + 1
                    Else
                        'else move on
                    End If
                    
                Next k
            Next j
            
        End With
    End Sub
    NOTE: This code is no different from first post; I could not see the "code" buttons (no text on them for some reason).

  4. #4

    Thread Starter
    Lively Member
    Join Date
    Feb 2012
    Location
    Manchester, UK
    Posts
    90

    Re: If employee has multiple rows for same period - VBA (EXCEL)

    vbfbryce this code works perfect! After testing I noticed that I requested one thing incorrectly.

    Im not sure if your code was meant to total the Days Excluded (col G) but the had not been totalled on the sheet("NEW")

    anyhow

    Column H (Days Excluded) is now "Days Worked" this needs totalling (when employee has multiple rows) then deducting from the number of days between the two dates.

    Sorry to be a pain. Other than that it is working perfect! This is the final bit of the Project then its complete

  5. #5

    Thread Starter
    Lively Member
    Join Date
    Feb 2012
    Location
    Manchester, UK
    Posts
    90

    Re: If employee has multiple rows for same period - VBA (EXCEL)

    Never mind managed to do it

    Code:
    Option Explicit
    
    Sub copyToNew()
        Dim wb As Workbook
        Dim wsTest As Worksheet
        Dim wsNew As Worksheet
        Dim lr As Long
        Dim wr As Long
        Dim j As Long
        Dim k As Long
        Dim m As Integer
        Dim n As Integer
        Dim rngSort As Range
        Dim rngKey1 As Range
        Dim rngKey2 As Range
        Dim emps() As String
        Dim counter As Long
        Dim empStart As Long
        Dim empEnd As Long
        Dim writeRow As Long
        Dim sumSal As Long
        Dim sumDays As Double
        Dim sumPer As Double
        Dim ftaNew As Double
        
        Set wb = ActiveWorkbook
        Set wsTest = wb.Worksheets("TESTING")
        Set wsNew = wb.Worksheets("NEW")
        
        lr = wsTest.Range("a" & Rows.Count).End(xlUp).Row
        
        For j = 2 To lr
            If wsTest.Range("a" & j).Value <> wsTest.Range("a" & j - 1).Value Then
                ReDim Preserve emps(counter)
                emps(counter) = wsTest.Range("a" & j).Value
                counter = counter + 1
            End If
        Next j
        Set rngSort = wsTest.Range("a1:h" & lr)
        Set rngKey1 = wsTest.Range("a2:a" & lr)
        Set rngKey2 = wsTest.Range("d2:d" & lr)
        
        With wsTest.Sort
            .SortFields.Clear
            .SortFields.Add Key:=rngKey1
            .SortFields.Add Key:=rngKey2
            .SetRange rngSort
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        
        empStart = 2
        
        With wsTest
            For j = 0 To UBound(emps)
                For k = empStart + 1 To lr
                    If .Range("d" & k).Value <> .Range("d" & k - 1).Value Then
                        empEnd = k - 1
                        writeRow = wsNew.Range("a" & Rows.Count).End(xlUp).Row + 1
                        If empStart = empEnd Then
                            For m = 1 To 5
                                wsNew.Cells(writeRow, m).Value = wsTest.Cells(k - 1, m).Value
                            Next m
                        Else
                            sumSal = 0
                            sumPer = 0
                            sumDays = 0
                            For n = empStart To empEnd
                                sumSal = sumSal + .Range("g" & n).Value
                                sumPer = sumPer + .Range("f" & n).Value
                                sumDays = sumDays + .Range("h" & n).Value
                            Next n
                            ftaNew = sumSal / sumPer
                            wsNew.Range("a" & writeRow).Value = wsTest.Range("a" & empStart).Value
                            wsNew.Range("b" & writeRow).Value = ftaNew
                            wsNew.Range("c" & writeRow).Value = 1
                            wsNew.Range("d" & writeRow).Value = wsTest.Range("d" & empStart).Value
                            wsNew.Range("e" & writeRow).Value = wsTest.Range("e" & empEnd).Value
                            wsNew.Range("f" & writeRow).Value = DateDiff("d", wsNew.Range("d" & writeRow).Value, wsNew.Range("e" & writeRow).Value) + 1 - sumDays
                            
                        End If
                        empStart = empEnd + 1
                    Else
                        'else move on
                    End If
                    
                Next k
            Next j
            
        End With
    End Sub
    I can follow your code from "With wsTest" but dont get what is happening with the counter and stuff in the first part of the code.

    Code:
        For j = 2 To lr
            If wsTest.Range("a" & j).Value <> wsTest.Range("a" & j - 1).Value Then
                ReDim Preserve emps(counter)
                emps(counter) = wsTest.Range("a" & j).Value
                counter = counter + 1
            End If
        Next j
    Would you be able to explain briefly?

    Thanks again
    Chris

  6. #6
    PowerPoster
    Join Date
    Oct 2008
    Location
    Midwest Region, United States
    Posts
    3,574

    Re: If employee has multiple rows for same period - VBA (EXCEL)

    I defined an array variable in which to store the employee ID's. I'm re-dimming it (changing the size of it) every time a new employee ID is found. The first time its done, "counter" is zero. Since arrays are "zero-based," that's what we want the first one to be. Then we increment counter, so the next time through the loop one is the upper boundary (now 2 elements in the array). Make sense?

  7. #7

    Thread Starter
    Lively Member
    Join Date
    Feb 2012
    Location
    Manchester, UK
    Posts
    90

    Re: If employee has multiple rows for same period - VBA (EXCEL)

    Kind of, in short are you counting the number of Employee's in the data?

    After stepping through a few times I think I have kind of figured out what everything is doing

    Will step through it a few more times tomorrow.

    Pretty sure i will be able to get it to calculate the "Percentage worked", "ANNAUL Part-time salary", "Days worked" within the code.

    Because you have probably noticed that following the results of TnTinMN's code i have added these 3 columns in.

    EXCITED!! This has probably save around a months worth of manual work in total!

  8. #8
    PowerPoster
    Join Date
    Oct 2008
    Location
    Midwest Region, United States
    Posts
    3,574

    Re: [RESOLVED] If employee has multiple rows for same period - VBA (EXCEL)

    Yes, counting the number of employees. Glad we could help!

  9. #9
    PowerPoster
    Join Date
    Oct 2010
    Posts
    2,141

    Re: [RESOLVED] If employee has multiple rows for same period - VBA (EXCEL)

    I know I am late to the party, but this current data looks as though it is the same structure as the previous one with the exception of the three added columns. Assuming that is correct, the logic implemented in the prior solution already includes determining the number of records in each entry. You could just insert a new method call at line 91 (Call AddtoResults) of that code to write to this "NEW" worksheet as all the information is available at that point in the code (Employee #, start of record set, # records in set). That way you would only need to process the file once.

    However, do whatever you are comfortable with supporting and make sure that you understand the logic as it is your baby now. Feel free to ask any questions you may have about the earlier code.

  10. #10

    Thread Starter
    Lively Member
    Join Date
    Feb 2012
    Location
    Manchester, UK
    Posts
    90

    Re: [RESOLVED] If employee has multiple rows for same period - VBA (EXCEL)

    Strange, im not sure if it is because this thread is marked as resolved but i never got an email notification about these replies.

    Hi TnTinMN, vbfbryce (could you guys not of used USERNAMES easier to remember/type haha) has created some code for the second part. I have managed to work out how his code works and have learnt a lot from it. When i have a couple of HOURS to spare i'm going to tackle figuring out how your code works

    Then work on merging the two.

    Thats the good thing about people helping me out, i'm not just asking for code to get the job done. If im asking for code i obviously dont know how to code it myself, so when i get the code i learn from it which makes my knowledge of vba that little bit stronger.

  11. #11

    Thread Starter
    Lively Member
    Join Date
    Feb 2012
    Location
    Manchester, UK
    Posts
    90

    Re: [RESOLVED] If employee has multiple rows for same period - VBA (EXCEL)

    Sorry vbfbryce

    After more vigorous testing the code doesnt seem to work for the final period of data.

    If i have the following data i get no result

    Employee Full time ANNUAL salary Monthly earnings Pay date from Pay Date to Percentage worked ANNAUL Part-time salary Days worked
    310387 £31,924.00 £1,330.17 01/04/2013 30/04/2013 51% £16,184 15
    310387 £27,864.00 £1,161.00 01/04/2013 30/04/2013 51% £14,126 15

    If i add a line below this then it works but the final period is not calculated.

    310387 £31,924.00 £1,330.17 01/04/2013 30/04/2013 51% £16,184 15
    310387 £27,864.00 £1,161.00 01/04/2013 30/04/2013 51% £14,126 15
    310387 £27,864.00 £1,161.00 01/05/2013 31/05/2013 49% £13,670 15

    Please help this I need to get the code tested and working for 31st March

  12. #12
    PowerPoster
    Join Date
    Oct 2008
    Location
    Midwest Region, United States
    Posts
    3,574

    Re: [RESOLVED] If employee has multiple rows for same period - VBA (EXCEL)

    Can you show us the most current code?

  13. #13

    Thread Starter
    Lively Member
    Join Date
    Feb 2012
    Location
    Manchester, UK
    Posts
    90

    Re: [RESOLVED] If employee has multiple rows for same period - VBA (EXCEL)

    Of course, I have just added a bit to your original code that calculates the 3 additional columns (marked in red)

    Code:
    Option Explicit
    
    Sub copyToNew()
        Dim wb As Workbook
        Dim wsTest As Worksheet, wsNew As Worksheet
        Dim lr As Long, wr As Long, j As Long, k As Long
        Dim m As Integer, n As Integer
        Dim rngSort As Range, rngKey1 As Range, rngKey2 As Range
        Dim counter As Long, empStart As Long, empEnd As Long
        Dim writeRow As Long, sumSal As Long
        Dim sumDays As Double, sumPer As Double, ftaNew As Double
        Dim emps() As String
        Dim f As Double
        
        Set wb = ActiveWorkbook
        Set wsTest = wb.Worksheets("TESTING")
        Set wsNew = wb.Worksheets("NEW")
        
        lr = wsTest.Range("a" & Rows.Count).End(xlUp).Row
        
            For j = 2 To lr
            'Percentage worked
            f = wsTest.Range("B" & j) / 365 * (DateDiff("d", wsTest.Range("d" & j), wsTest.Range("e" & j)) + 1)
            wsTest.Range("F" & j) = wsTest.Range("C" & j) / f * 1
            'Annual P/T salary
            wsTest.Range("G" & j).Value = wsTest.Range("B" & j).Value * wsTest.Range("F" & j)
            'Days worked
            wsTest.Range("H" & j).Value = wsTest.Range("C" & j).Value / wsTest.Range("B" & j).Value * 365
            
                If wsTest.Range("a" & j).Value <> wsTest.Range("a" & j - 1).Value Then
                    ReDim Preserve emps(counter)
                    emps(counter) = wsTest.Range("a" & j).Value
                    counter = counter + 1
                End If
            Next j
        
        Set rngSort = wsTest.Range("a1:h" & lr)
        Set rngKey1 = wsTest.Range("a2:a" & lr)
        Set rngKey2 = wsTest.Range("d2:d" & lr)
        
            With wsTest.Sort
                .SortFields.Clear
                .SortFields.Add Key:=rngKey1
                .SortFields.Add Key:=rngKey2
                .SetRange rngSort
                .Header = xlYes
                .MatchCase = False
                .Orientation = xlTopToBottom
                .SortMethod = xlPinYin
                .Apply
            End With
        
        empStart = 2
        
            With wsTest
                For j = 0 To UBound(emps)
                    For k = empStart + 1 To lr
                        If .Range("d" & k).Value <> .Range("d" & k - 1).Value Then
                            empEnd = k - 1
                            writeRow = wsNew.Range("a" & Rows.Count).End(xlUp).Row + 1
                            If empStart = empEnd Then
                                For m = 1 To 5
                                    wsNew.Cells(writeRow, m).Value = wsTest.Cells(k - 1, m).Value
                                Next m
                            Else
                                sumSal = 0
                                sumPer = 0
                                sumDays = 0
                                For n = empStart To empEnd
                                    sumSal = sumSal + .Range("g" & n).Value
                                    sumPer = sumPer + .Range("f" & n).Value
                                    sumDays = sumDays + .Range("h" & n).Value
                                Next n
                                ftaNew = sumSal / sumPer
                                wsNew.Range("a" & writeRow).Value = wsTest.Range("a" & empStart).Value
                                wsNew.Range("b" & writeRow).Value = ftaNew
                                wsNew.Range("c" & writeRow).Value = 1
                                wsNew.Range("d" & writeRow).Value = wsTest.Range("d" & empStart).Value
                                wsNew.Range("e" & writeRow).Value = wsTest.Range("e" & empEnd).Value
                                wsNew.Range("f" & writeRow).Value = DateDiff("d", wsNew.Range("d" & writeRow).Value, wsNew.Range("e" & writeRow).Value) + 1 - sumDays
                            End If
                            empStart = empEnd + 1
                        End If
                        
                    Next k
                Next j
                
            End With
    End Sub
    
    End Sub

  14. #14
    PowerPoster
    Join Date
    Oct 2008
    Location
    Midwest Region, United States
    Posts
    3,574

    Re: [RESOLVED] If employee has multiple rows for same period - VBA (EXCEL)

    I'm not sure I understand the condition (from #11) that causes the issue.

  15. #15

    Thread Starter
    Lively Member
    Join Date
    Feb 2012
    Location
    Manchester, UK
    Posts
    90

    Re: [RESOLVED] If employee has multiple rows for same period - VBA (EXCEL)

    No matter how much data there is the last period of dates in the list does not get processed by the code.

    If you paste the data in #11 the first set of data will not process to the sheets "NEW"

    the second set of data the period 01/04/2013 - 30/04/2013 will process but 01/05/2013 - 31/05/2013 will not.

    Its just the LAST period of data that does not get processed. Unless you only have one period of data where nothing gets processed.

  16. #16
    PowerPoster
    Join Date
    Oct 2008
    Location
    Midwest Region, United States
    Posts
    3,574

    Re: [RESOLVED] If employee has multiple rows for same period - VBA (EXCEL)

    Ok, could you zip and attach a book with a small amount of data that I can test it on? Or is something suitable already attached?

  17. #17
    PowerPoster
    Join Date
    Oct 2010
    Posts
    2,141

    Re: [RESOLVED] If employee has multiple rows for same period - VBA (EXCEL)

    I awoke to another frigid day here (7F), so I thought that I would take a look at this again. I have modified the original to add the three new columns to the grouping results and also added the new summary sheet.

    Here is the result: Test Data (to submit).zip

  18. #18

    Thread Starter
    Lively Member
    Join Date
    Feb 2012
    Location
    Manchester, UK
    Posts
    90

    Re: [RESOLVED] If employee has multiple rows for same period - VBA (EXCEL)

    Quote Originally Posted by TnTinMN View Post
    I awoke to another frigid day here (7F), so I thought that I would take a look at this again. I have modified the original to add the three new columns to the grouping results and also added the new summary sheet.

    Here is the result: Test Data (to submit).zip
    Wow! everything in one go. I have just tested it with a small amount of data and it is working perfect.

    Working in payroll means lots of deadlines and I have quiet a bit to do today. But will try get this tested with a large amount of data tomorrow.

    Thanks again for all the time your guys have spent scratching your heads and putting this code together :P

Posting Permissions

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



Click Here to Expand Forum to Full Width