Find duplicate values and combine rows

[Diving_Dan]

Hi all,

I have a data report that gives figures for individual employees. For whatever reason when I am being provided with the report I am getting multiple rows of data for one employee.

Column A has the employee ID, and then Columns B onward hold figures to do with the employee's productivity.

What I am trying to achieve is to loop through all cells in column A, and for each cell look to see if there are any other cells with the same range that have the same employee ID. If there are I only want 1 row of data for that Employee ID so would need to sum columns B, C, D etc and then remove duplicates. I hope that makes sense. Any help is appreciated as always.

Dan

 

[Fluff]

How about

Sub DivingDan()
   Dim Ary As Variant, Nary As Variant
   Dim r As Long, c As Long, nr As Long
   
   Ary = Sheets("Sheet1").Range("A1").CurrentRegion.Value2
   ReDim Nary(1 To UBound(Ary), 1 To UBound(Ary, 2))
   
   With CreateObject("scripting.dictionary")
      For r = 2 To UBound(Ary)
         If Not .Exists(Ary(r, 1)) Then
            nr = nr + 1
            .Add Ary(r, 1), nr
            Nary(nr, 1) = Ary(r, 1)
         End If
         For c = 2 To UBound(Ary, 2)
            Nary(.Item(Ary(r, 1)), c) = Ary(r, c) + Nary(.Item(Ary(r, 1)), c)
         Next c
      Next r
   End With
   Sheets("Sheet2").Range("A2").Resize(nr, UBound(Ary, 2)).Value = Nary
End Sub

 

[CA_Punit]

Question:

if there are say Employees ID 10001 in Two Rows do you want to sum all the Column of both the rows or only sum up one Row and remove the duplicate one.

As @Fluff has already provided you solution using VBA do you want a formula based solution.

 

[Diving_Dan]

Thanks Fluff, as always does exactly what I need. How would I change the code to only combine the Columns K:Z as I just realised columns B:J contain information on what team they are assigned to and other personal data.

Thanks

Dan

 

[Fluff]

How about

Sub DivingDan()
   Dim Ary As Variant, Nary As Variant
   Dim r As Long, c As Long, nr As Long
   
   Ary = Sheets("Sheet1").Range("A1").CurrentRegion.Value2
   ReDim Nary(1 To UBound(Ary), 1 To UBound(Ary, 2))
   
   With CreateObject("scripting.dictionary")
      For r = 2 To UBound(Ary)
         If Not .Exists(Ary(r, 1)) Then
            nr = nr + 1
            .Add Ary(r, 1), nr
            For c = 1 To 10
               Nary(nr, c) = Ary(r, c)
            Next c
         End If
         For c = 11 To UBound(Ary, 2)
            Nary(.Item(Ary(r, 1)), c) = Ary(r, c) + Nary(.Item(Ary(r, 1)), c)
         Next c
      Next r
   End With
   Sheets("Sheet2").Range("A2").Resize(nr, UBound(Ary, 2)).Value = Nary
End Sub

 

[Diving_Dan]

Absolutely perfect. Thanks Fluff

 

[Fluff]

You're welcome & thanks for the feedback.