Adding rows with the same A column value; cleaning code

[KateA]

Hi,

I've got a spreadsheet with lots of company names in column A and various different figures in columns B through to a number that changes often. If the names are the same, I'd like to add all the corresponding values and be left with unique entries in A. This block does the job but i have to run it two or three times so it catches everything, as some companies are repeated ten+ times. Can anybody see a more elegant and error-proof way of coding this?

For a = 2 To x
For b = 1 To x
If Worksheets(SheetName).Cells(a, 1).Value = Worksheets(SheetName).Cells(a, 1).Offset(b, 0).Value Then
For Col = 2 To 8
ValueA = Worksheets(SheetName).Cells(a, Col).Value
ValueB = Worksheets(SheetName).Cells(a, Col).Offset(b, 0).Value
NewValue = ValueA + ValueB
Worksheets(SheetName).Cells(a, Col).Value = NewValue
Next Col
Worksheets(SheetName).Cells(a, 1).Offset(b, 0).EntireRow.Delete
End If
Next b
Next a

Thanks,

Kate

 

[Debraj]

Any sample file .. with expected output..

 

[p45cal]

try:

'x = 13
'sheetname = "Sheet1"
With Worksheets(sheetname)
  'sort on column A first:
  With .Sort
    .SortFields.Clear
    .SortFields.Add Key:=Range("A1:A" & x), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    .SetRange Range("A1:H" & x)
    .Header = xlYes
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
  End With
  'then work up the list once only:
  For rw = x To 3 Step -1
    If .Cells(rw, 1) = .Cells(rw - 1, 1) Then
      For Col = 2 To 8
        .Cells(rw - 1, Col).Value = .Cells(rw - 1, Col).Value + .Cells(rw, Col).Value
      Next Col
      .Rows(rw).Delete
    End If
  Next rw
End With

Otherwise a pivot table will give exactly the same results more robustly and quicker.

 

[KateA]

It works beautifully! Thank you for your help!