Vba to sum up rows based on column a & b and delete duplicate rows

**kevivu** · 02-04-2016, 06:37 PM

Hi All,

Here is my requirement, i.e. here COL A & B will be the key ORAs combination of these two should be unique. Based on this i need to merge (sum) the rows and sum up COL C D E but need to calculate the percentage diff based on the below formula.. Also one more thing i.e. like COL C to COL F (1 set), i have 39 to 45 more sets, which means need to sum up COL G H I and find the percentage diff using formula for COL J and again sum up COL K L M and find pct diff for COL N, etc.......

would you please help me on this please.

COL A COL B COL C COL D COL E COL F
a b c1 d1 dif1 pctdif1
disc1 song1234 3 20 -17 =(COL E)/(COL C)*100
disc2 song78 2 30 -18 =(COL E)/(COL C)*100
disc1 song54 1 10 -9 =(COL E)/(COL C)*100
disc3 song4 4 10 -6 =(COL E)/(COL C)*100
disc4 song0 1 15 -14 =(COL E)/(COL C)*100
disc2 song78 2 16 -14 =(COL E)/(COL C)*100
disc1 song1234 0 19 -19 =(COL E)/(COL C)*100
disc4 song9 1 20 -19 =(COL E)/(COL C)*100
disc1 song1234 0 10 -10 =(COL E)/(COL C)*100

Attached an excel sheet with expected result:

**kevivu** · 02-04-2016, 08:20 PM

All,

Wud you please modify this code to work for my example...

Sub sourcemod()

Dim Rng As Range
Dim InputRng As Range
Dim nRng As Range
Application.ScreenUpdating = False
Set InputRng = Application.Selection
Set InputRng = Application.InputBox("Range :", xTitleId, InputRng.Address, Type:=8)
Set InputRng = InputRng.Parent.Range(InputRng.Columns(1).Address)
With CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
For Each Rng In InputRng
    If Not .Exists(Rng.Value) Then
        .Add Rng.Value, Rng.Offset(, 1)
    Else
        .Item(Rng.Value).Value = .Item(Rng.Value).Value + Rng.Offset(, 1)
            If nRng Is Nothing Then
                Set nRng = Rng
            Else
                Set nRng = Union(nRng, Rng)
            End If
    End If
Next
If Not nRng Is Nothing Then
    nRng.EntireRow.Delete
End If
End With
Application.ScreenUpdating = True
End Sub

**jaslake** · 02-05-2016, 03:15 PM

Hi kevivu

This Code is in the attached and appears to do as required on your Sample Data. Make certain you have a Sheet named Sheet2. CTRL + x will fire the Code.

Option Explicit

Sub Test()
   Dim LR           As Long
   Dim LR1          As Long

   Sheets("Sheet2").Cells.Clear

   With Sheets("Sheet1")
      LR = .Cells.Find("*", .Cells(.Rows.Count, .Columns.Count), SearchOrder:=xlByRows, _
                       SearchDirection:=xlPrevious).Row
      .Range("A1:B" & LR).AdvancedFilter Action:=xlFilterCopy, _
                                         CopyToRange:=Sheets("Sheet2").Range("A1"), Unique:=True
      .Range(.Cells(1, "C"), .Cells(1, "F")).Copy Sheets("Sheet2").Range("C1")
   End With

   With Sheets("Sheet2")
      LR1 = .Cells.Find("*", .Cells(.Rows.Count, .Columns.Count), SearchOrder:=xlByRows, _
                        SearchDirection:=xlPrevious).Row
      .Cells(2, "C").Formula = "=SUMIF(Sheet1!$B$2:$B" & LR & ",Sheet2!$B2,Sheet1!C$2:C" & LR & ")"
      .Cells(2, "D").Formula = "=SUMIF(Sheet1!$B$2:$B" & LR & ",Sheet2!$B2,Sheet1!D$2:D" & LR & ")"
      .Cells(2, "E").Formula = "=SUMIF(Sheet1!$B$2:$B" & LR & ",Sheet2!$B2,Sheet1!E$2:E" & LR & ")"
      .Cells(2, "F").Formula = "=E2/C2"
      .Range("C2:F2").AutoFill Destination:=.Range("C2:F" & LR1), Type:=xlFillDefault
      .Range("F2:F" & LR1).NumberFormat = "0.00"
      .Activate
   End With
End Sub