Sum, Merge and Delete Duplicate Rows

**astoria** · 09-06-2010, 11:56 AM

My Worksheet Contains Following Columns

sr no. | name | rate | add this | add this | add this |.......

Need a Macro to Compare Name and Rate and If same Name and rate is Found same for 2 or more rows Retain First Sr no. , name , rate and add all other columns and then delete duplicate rows

Here is the Example Of what i want

sr no | name | rate | add this | add this

1 abc 100 50 10
2 xyz 100 10 30
3 abc 100 60 20
4 pqr 100 25 40
5 abc 250 10 15

I want this to be Converted To

sr no | name | rate | add this | add this

1 abc 100 110 30
2 xyz 100 10 30
4 pqr 100 25 40
5 abc 250 10 15

i.e rows are added and merged only when name and rates both match and also sr no. must not be changed

(Also there can be n columns out of which except first 3 all other cols must be added)

**rylo** · 09-06-2010, 07:18 PM

Hi

This is based on your example structure, and assumes that you have some blank columns that you can use. If you have variable column widths, then this could be modified to cover.

Sub aaa()
  lastrow = Cells(Rows.Count, 1).End(xlUp).Row
  
  Range("H2").Formula = "=SUMPRODUCT(--($B$2:$B2=B2),--($C$2:$C2=C2))"
  Range("I2").Formula = "=SUMPRODUCT(--($B$2:$B$" & lastrow & "=$B2),--($C$2:$C$" & lastrow & "=$C2),(D$2:D$" & lastrow & "))"
  Range("I2").Copy Destination:=Range("J2:K2")
  Range("H2:K2").AutoFill Destination:=Range("H2:K" & lastrow)
  
  For i = 2 To lastrow
    If Cells(i, "H") = 1 Then
      Range("D" & i).Resize(1, 3).Value = Cells(i, "I").Resize(i, 3).Value
    End If
  Next i
    
  For i = lastrow To 2 Step -1
    If Cells(i, "H") > 1 Then
      Cells(i, "A").EntireRow.Delete shift:=xlUp
    End If
  Next i
  
  Range("H:K").ClearContents
      
End Sub

rylo

**Leith Ross** · 09-06-2010, 08:15 PM

Hello astoria,

Welcome to the Forum!

The attached workbook has the macro below added and a button on the worksheet to run it.

'http://www.excelforum.com/excel-programming/744632-sum-merge-and-delete-duplicate-rows.html
'Written: Septemeber 07, 2010
'Author:  Leith Ross

Sub MergeData()

  Dim C As Long
  Dim Data As Variant
  Dim Dict As Object
  Dim Key As Variant
  Dim R As Long
  Dim Rng As Range
  Dim RngEnd As Range
  Dim Wks As Worksheet
  
    Set Wks = Worksheets("Sheet1")
    
    Set Rng = Wks.Range("A1", Wks.Cells(1, Columns.Count).End(xlToLeft)).Offset(1, 0)
    Set RngEnd = Wks.Cells(Rows.Count, Rng.Column).End(xlUp)
    Set Rng = Wks.Range(Rng, RngEnd)
    
    Set Dict = CreateObject("Scripting.Dictionary")
    Dict.CompareMode = vbTextCompare
    
    
      For Each Cell In Rng.Columns(1).Cells
        Key = Trim(Cell.Offset(0, 1)) & Trim(Cell.Offset(0, 2))
        If Not Dict.Exists(Key) Then
           ReDim Data(Rng.Columns.Count - 1)
             Data(0) = Cell                  'SR Number
             Data(1) = Cell.Offset(0, 1)     'Name
             Data(2) = Cell.Offset(0, 2)     'Rate
           For C = 3 To Rng.Columns.Count - 1
             Data(C) = Cell.Offset(0, C)
           Next C
           Dict.Add Key, Data
        Else
           Data = Dict(Key)
             For C = 3 To Rng.Columns.Count - 1
               Data(C) = Data(C) + Cell.Offset(0, C)
             Next C
           Dict(Key) = Data
        End If
      Next Cell
      
      Application.ScreenUpdating = False
      
        Rng.ClearContents
      
        For Each Key In Dict.Keys
          R = R + 1
          Rng.Rows(R).Value = Dict(Key)
        Next Key
      
      Application.ScreenUpdating = True
      
    Set Dict = Nothing
    
End Sub

Thread: Sum, Merge and Delete Duplicate Rows

Thread Tools

Display

Sum, Merge and Delete Duplicate Rows

Re: Sum, Merge and Delete Duplicate Rows

Re: Sum, Merge and Delete Duplicate Rows

Thread Information

Users Browsing this Thread

Tags for this Thread

Bookmarks

Bookmarks

Posting Permissions