Please help me combine duplicate rows and average 2 columns

[pluqk]

Hi, i'm new here.

This is an example of what I am having difficulty doing.


Raw Data
Name......ID..Score1..Score2
Racket....3...10......9
Ball......2...20......14
Stick.....5...5.......23
Shoe......9...6.......42
Shoe......9...8.......12
Keyboard..4...3.......7
Keyboard..4...9.......4
Keyboard..4...12......1

Desired Result
Name......ID..Score1..Score2
Racket....3...10......9
Ball......2...20......14
Stick.....5...5.......23
Shoe......9...7.......27
Keyboard..4...8.......4




Basically I want to combine duplicates based on column 1, transfer column 2 over, and average the results of duplicates of column 3 and 4

[mehmetcik]

try this macro

[/CODE]

Sub Macro1()

LR = Range("A65536").End(xlUp).Row

Range("E2:E" & LR).FormulaR1C1 = "=IF(RC[-4]=R[-1]C[-4],R[-1]C+1,0)"
Range("F2:F" & LR).FormulaR1C1 = "=IF(RC[-1]>0,RC[-3]+R[-1]C,RC[-3])"
Range("G2:G" & LR).FormulaR1C1 = "=IF(RC[-2]>0,RC[-3]+R[-1]C,RC[-3])"
Range("H2:H" & LR).FormulaR1C1 = _
"=IF(AND(RC[-3]>0,OR(R[1]C[-3]=0,R[1]C[-3]="""")),RC[-2]/(RC[-3]+1),RC[-2])"
Range("I2:I" & LR).FormulaR1C1 = _
"=IF(AND(RC[-4]>0,OR(R[1]C[-4]=0,R[1]C[-4]="""")),RC[-2]/(RC[-4]+1),RC[-2])"
Range("J2:" & LR).FormulaR1C1 = "=IF(RC[-9]=R[1]C[-9],0,1)"


Range("E2:J" & LR).Value = Range("E2:J" & LR).Value

Range("A1:J" & LR).Select
Application.CutCopyMode = False
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("J2:J" & LR), _
SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Sheet1").Sort
.SetRange Range("A1:J" & LR)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("J1:J" & LR).Select
Selection.Find(What:="0", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Activate
Rows(ActiveCell.Row & ":" & LR).Select
Selection.Delete Shift:=xlUp
Columns("J:J").Delete Shift:=xlToLeft
Range("C2:G" & LR).Delete Shift:=xlToLeft
Range("A1").Select
End Sub
[/CODE]

[Marc L]

Hi,

assuming data from columns A to D, nothing in column E, starts in row 1,
code to paste directly to the worksheet module :

Sub Demo()
    With [A1].CurrentRegion
        ReDim RC(1 To .Rows.Count, 1 To 5):  VA = .Value

        For R& = 1 To .Rows.Count
                       V = Application.Match(VA(R, 2), Application.Index(RC, , 2), 0)
            If IsError(V) Then
                    N& = N& + 1:  RC(N, 5) = 1
                For C% = 1 To 4:  RC(N, C) = VA(R, C):  Next
            Else
                                  RC(V, 5) = RC(V, 5) + 1
                 For C = 3 To 4:  RC(V, C) = RC(V, C) + VA(R, C):  Next
            End If
        Next

        For R = 2 To N
            If RC(R, 5) > 1 Then For C = 3 To 4: RC(R, C) = RC(R, C) / RC(R, 5): Next
        Next

        .Value = RC:  Erase RC, VA
    End With
End Sub

Enjoy it and don't forget to click on bottom left star « Add Reputation », thanks !

[pluqk]

thanks for the help but, the first one has the correct values but didn't combine rows properly (gave me an error), and the second one didn't work at all. does anyone have any suggestions? im kind of stuck here

[Marc L]

Mine works like a charm on my side on several computers with different Excel versions ‼

_________________________________________________________________________________________________
If you can’t explain it simply, you don’t understand it well enough … (Albert Einstein)

[pluqk]

Hi Marc, it wasnt working for me earlier before some of the data in columns 3 and 4 arent values ("Not Scoreable") so it was giving me an error. is there any way I can delete rows which "Not Scoreable" as a value on top of deleting duplicates.

Also, thanks for the help, and sorry for not realizing it was my error!

[Marc L]

is there any way I can delete rows which "Not Scoreable" as a value on top of deleting duplicates.

You can add a condition to check bad rows and delete them …

[mehmetcik]

My Apologies.

Try this:-

Sub Macro1()

LR = Range("A65536").End(xlUp).Row

    Range("A1:D" & LR).Select
    ActiveWorkbook.Worksheets("Backup").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Backup").Sort.SortFields.Add Key:=Range("B2:B9"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Backup").Sort
        .SetRange Range("A1:D9")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
    Range("E2:E" & LR).FormulaR1C1 = "=IF(RC[-4]=R[-1]C[-4],R[-1]C+1,0)"
    Range("F2:F" & LR).FormulaR1C1 = "=IF(RC[-1]>0,RC[-3]+R[-1]C,RC[-3])"
    Range("G2:G" & LR).FormulaR1C1 = "=IF(RC[-2]>0,RC[-3]+R[-1]C,RC[-3])"
    Range("H2:H" & LR).FormulaR1C1 = _
        "=IF(AND(RC[-3]>0,OR(R[1]C[-3]=0,R[1]C[-3]="""")),RC[-2]/(RC[-3]+1),RC[-2])"
    Range("I2:I" & LR).FormulaR1C1 = _
        "=IF(AND(RC[-4]>0,OR(R[1]C[-4]=0,R[1]C[-4]="""")),RC[-2]/(RC[-4]+1),RC[-2])"
       Range("J2:J" & LR).FormulaR1C1 = "=IF(RC[-9]=R[1]C[-9],0,1)"


    Range("E2:J" & LR).Value = Range("E2:J" & LR).Value
    
    Range("A1:J9").Select
    ActiveWorkbook.Worksheets("Backup").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Backup").Sort.SortFields.Add Key:=Range("J2:J9"), _
        SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Backup").Sort
        .SetRange Range("A1:J9")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

    Range("J1:J" & LR).Select
    Selection.Find(What:="0", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
        :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
        False, SearchFormat:=False).Activate
    Rows(ActiveCell.Row & ":" & LR).Select
    Selection.Delete Shift:=xlUp
    Columns("J:J").Delete Shift:=xlToLeft
    Range("C2:G" & LR).Delete Shift:=xlToLeft
    Range("A1").Select
End Sub

[pluqk]

Thanks for all the help everyone, it's working perfectly now