Delete multiple employee rows based on greatest amount of hours and dept

[jassybun]

Hey guys! I am trying to find a module that would automatically delete rows that are the people with same dept and same timecard but keep the row with the most amount of time, like this:

Dept.....Employee........Hours
1..........John Moore.....8.10
1..........John Moore.....2.13
1...........Alice Cho........4.00
1...........Alice Cho........2.32
4...........Alice Cho........3.40
4...........Mark Miller......3.00

Would result in:

Dept.....Employee........Hours
1..........John Moore.....8.10
1...........Alice Cho........4.00
4...........Alice Cho........3.40
4...........Mark Miller......3.00

similar post from someone else in SQL:
http://www.sqlservercentral.com/Forums/Topic744538-338-1.aspx#bm744622

 

[NARAYANK991]

Hi ,

Try this in the Workbook section of your VBE :

Public Sub Copy_Highest()
'          The following named ranges have been created in the worksheet :
'          Data_Range  defined as :    =Sheet1!$A$2:$C$7
'          Dept        defined as :    =Index(Data_Range, 0, 1)
'          Employee    defined as :    =Index(Data_Range, 0, 2)
'          Hours      defined as :    =Index(Data_Range, 0, 3)
          Dim i As Long
          Dim department As Variant, emp As Variant, hrs As Variant
          Dim src_wks As Worksheet, dest_wks As Worksheet
          Set src_wks = ThisWorkbook.Worksheets("Sheet1")        ' Change as required
          Set dest_wks = ThisWorkbook.Worksheets("Sheet2")      ' Change as required
       
          src_wks.Activate
          department = ActiveSheet.Range("Dept").Value
          emp = ActiveSheet.Range("Employee").Value
          hrs = ActiveSheet.Range("Hours").Value
       
          For i = LBound(emp) To UBound(emp)
              curr_dept = department(i, 1)
              curr_emp = emp(i, 1)
              curr_hrs = 0
           
              For j = LBound(emp) To UBound(emp)
                  If curr_dept = department(j, 1) And curr_emp = emp(j, 1) Then
                      If hrs(j, 1) > curr_hrs Then curr_hrs = hrs(j, 1)
                  End If
              Next
           
              dest_wks.Activate
              With ActiveSheet
                    matchfound = False
                    For l = 0 To k
                        old_dept = .Cells(2 + l, 1).Value
                        old_emp = .Cells(2 + l, 2).Value
                        If old_dept = curr_dept And old_emp = curr_emp Then
                          matchfound = True
                          Exit For
                        End If
                    Next
                 
                    If Not matchfound Then
                      .Cells(2 + k, 1) = curr_dept
                      .Cells(2 + k, 2) = curr_emp
                      .Cells(2 + k, 3) = curr_hrs
                      k = k + 1
                    End If
              End With
              src_wks.Activate
            Next
End Sub

If you go through the comments at the beginning of the procedure , you will see that the procedure depends for its correct execution on the existence of 4 named ranges ; please define them in your worksheet before you run this procedure.

Narayan

 

[jassybun]

that is excellent! Thank you so much. I have one more question - is there a way to make this into an automatic function, like whenever there is a change made, instead of manually running the macro? The employee who runs this report will be copying and pasting the hours into the excel sheet1.

 

[NARAYANK991]

that is excellent! Thank you so much. I have one more question - is there a way to make this into an automatic function, like whenever there is a change made, instead of manually running the macro? The employee who runs this report will be copying and pasting the hours into the excel sheet1.

Hi ,

This may be possible , but I see the following difficulty viz. when ever fresh data is entered , the newly entered hours may be the current maximum ; this will therefore be transferred to the other sheet ; what happens if data is entered later which becomes a new maximum ; will this also not be transferred to the other sheet ? Is this acceptable ?

Narayan

 

[jassybun]

Before pasting the data into the sheet, we would clear the contents of the sheet. So it would not include previous data.

 

[NARAYANK991]

Hi ,

Try this :

Private Sub Worksheet_Change(ByVal Target As Range)
'           The following named ranges have been created in the worksheet :
'           Data_Range  defined as :    =Sheet1!$A$2:$C$7
'           Dept        defined as :    =Index(Data_Range, 0, 1)
'           Employee    defined as :    =Index(Data_Range, 0, 2)
'           Hours       defined as :    =Index(Data_Range, 0, 3)
            If Application.Intersect(Target, Range("Hours")) Is Nothing Then Exit Sub
                        
            Application.EnableEvents = False
            Application.ScreenUpdating = False
            
            Dim i As Long
            Dim department As Variant, emp As Variant, hrs As Variant
            Dim src_wks As Worksheet, dest_wks As Worksheet
            Set src_wks = ThisWorkbook.Worksheets("Sheet1")        ' Change as required
            Set dest_wks = ThisWorkbook.Worksheets("Sheet2")       ' Change as required
       
            dest_wks.Range("A2", dest_wks.Cells(2, 3).End(xlDown)).ClearContents
                        
            src_wks.Activate
            department = ActiveSheet.Range("Dept").Value
            emp = ActiveSheet.Range("Employee").Value
            hrs = ActiveSheet.Range("Hours").Value
       
            For i = LBound(emp) To UBound(emp)
                curr_dept = department(i, 1)
                curr_emp = emp(i, 1)
                curr_hrs = 0
           
                For j = LBound(emp) To UBound(emp)
                    If curr_dept = department(j, 1) And curr_emp = emp(j, 1) Then
                       If hrs(j, 1) > curr_hrs Then curr_hrs = hrs(j, 1)
                    End If
                Next
           
                dest_wks.Activate
                With ActiveSheet
                     matchfound = False
                     For l = 0 To k
                         old_dept = .Cells(2 + l, 1).Value
                         old_emp = .Cells(2 + l, 2).Value
                         If old_dept = curr_dept And old_emp = curr_emp Then
                            matchfound = True
                            Exit For
                         End If
                     Next
                 
                     If Not matchfound Then
                        .Cells(2 + k, 1) = curr_dept
                        .Cells(2 + k, 2) = curr_emp
                        .Cells(2 + k, 3) = curr_hrs
                        k = k + 1
                     End If
                End With
                src_wks.Activate
            Next
            Application.EnableEvents = True
            Application.ScreenUpdating = True
End Sub

Narayan

 

[Sam Mathai Chacko]

Just a side question (albeit the solution Narayan provided works already). Why didn't you think of a Pivot Table based solution? The source range could have been set dynamically. All you needed would then have been a one-liner code that refreshes the pivot table whenever data in the sheet changes.

 

[jassybun]

Narayan - I am almost there!!!! Once last question - if I have other fields that I need to paste over, say I have columns A-J that need to be copied over as well. Dept is column C, Employee is column E, and Hours is Column F. I did not think I needed the rest of the data, but I realize now that is not possible to not include it for my reports. I know how to adjust the data ranges - but how would I adjust the what is being pasted over?


Sam - great idea, but unfortunately, this table isn't the end report, it is just sorting out the raw data, which has other cells that reference it with equations (3 worksheets with various equations)..I could change all the equations and tables to become pivot tables or reference pivot data- but it would be a wild task, and time consuming - I am not sure I would be able to successfully accomplish it.

 

[NARAYANK991]

Hi ,

Sorry but it's late tonight for me , and I don't think I can do anything now ; first thing tomorrow. In the meantime , you can clarify something :

At present , the code is copying and pasting 3 columns from the defined named range Data_Range on the source worksheet , onto columns A , B and C on the destination worksheet.

You are now saying that the columns of interest are from A to J , though the columns to be checked are C , E and F instead of A , B and C ; is this correct ?

If this is the only change , then there is not much to be changed :

1. Change the definitions of the named ranges Data_Range , Dept , Employee and Hours as follows :

Data_Range defined as : =Sheet1!$A$2:$J$7
Dept defined as : =Index(Data_Range, 0, 3)
Employee defined as : =Index(Data_Range, 0, 5)
Hours defined as : =Index(Data_Range, 0, 6)

2. Change the following statement as given below :

dest_wks.Range("A2", dest_wks.Cells(2, 10).End(xlDown)).ClearContents

3. Change all the indices 1 , 2 and 3 in the below mentioned section of code to 3 , 5 and 6


For i = LBound(emp) To UBound(emp)
curr_dept = department(i, 1)
curr_emp = emp(i, 1)
curr_hrs = 0

For j = LBound(emp) To UBound(emp)
If curr_dept = department(j, 1) And curr_emp = emp(j, 1) Then
If hrs(j, 1) > curr_hrs Then curr_hrs = hrs(j, 1)
End If
Next

dest_wks.Activate
With ActiveSheet
matchfound = False
For l = 0 To k
old_dept = .Cells(2 + l, 1).Value
old_emp = .Cells(2 + l, 2).Value
If old_dept = curr_dept And old_emp = curr_emp Then
matchfound = True
Exit For
End If
Next

If Not matchfound Then
.Cells(2 + k, 1) = curr_dept
.Cells(2 + k, 2) = curr_emp
.Cells(2 + k, 3) = curr_hrs
k = k + 1
End If
End With
src_wks.Activate
Next

4. Lastly , you need to paste the other column data in the destination worksheet , but this can be done later ; can you do the above and see if everything continues to work as before ?

Narayan