VBA code to Sum duplicate values then delete duplicate rows

W

whassan

New Member
Joined
Dec 10, 2015
Messages
25
Office Version
  1. 2010
Platform
  1. Windows
Hi All,

I have 4 columns in my spreadsheet. I am trying to find any duplicates that may exist in Col D, sum values in Col C and concatenate corresponding values in Col B , then delete the entire row.

I have found VBA code on MRExcel website but honestly don't know how to tweak this code as per my requirements.

Any help that you can provide would be most appreciative.

I have attached data sample illustrating before and after as picture.

Before:

Col A Col B Col C Col D
AccountingGroupMon 06-Dec-21
321_AFSPRODUCT 1
39,400.00​
XS2395583995
321_AFSPRODUCT 2
67,800.00​
XS2395583995
321_AFSPRODUCT 3
67,800.00​
XS2395583995
321_AFSPRODUCT 4
29,500.00​
XS2395584456
321_AFSPRODUCT 5
67,400.00​
XS2395584456
321_AFSPRODUCT 6
2,000.00​
XS2395584456
321_AFSPRODUCT 7
9,100.00​
XS2395584456


After:

Col A Col B Col C Col D
AccountingGroupMon 06-Dec-21
321_AFSPRODUCT 1, PRODUCT 2, PRODUCT 3
175,000.00​
XS2395583995
321_AFSPRODUCT 4, PRODUCT 5, PRODUCT 6, PRODUCT 7
108,000.00​
XS2395584456


Sub Test()
Dim Sh As Worksheet
Dim LastRow As Long
Dim Rng As Range
Set Sh = Worksheets(1)
Sh.Columns(5).Insert
LastRow = Sh.Range("A65536").End(xlUp).Row
With Sh.Range("A1:A" & LastRow).Offset(0, 4)
.FormulaR1C1 = "=IF(COUNTIF(R1C[-4]:RC[-4],RC[-4])>1,"""",SUMIF(R1C[-4]:R[" & LastRow & "]C[-4],RC[-4],R1C[-1]:R[" & LastRow & "]C[-1]))"
.Value = .Value
End With
Sh.Columns(4).Delete
Sh.Rows(1).Insert
Set Rng = Sh.Range("D1:D" & LastRow + 1)
With Rng
.AutoFilter Field:=1, Criteria1:="="
.SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
End Sub
 

Excel Facts

Shade all formula cells
To shade all formula cells: Home, Find & Select, Formulas to select all formulas. Then apply a light fill color.
Sort by date Sort by votes
Sorry, I couldn't help myself. I tested it on your data. You may want to test it further.

VBA Code: 
Sub Summarize()
  Dim Cel As Range
  Dim R As Range
  Dim u As Range
  Dim CC As Range
  Dim RR As Range
  Dim Sht As Worksheet
  Dim PCode As String
  Dim PCodeRng As Range
  Dim BotRow As Range
  Dim TotalCost As Double
  Dim CostRng As Range
  Dim ProdStr As String
  Dim ProdRng As Range
  Dim AccGrp As String
  Dim Pu As Range
  Dim PCCnt As Long
  Dim X As Long
  
  Set Sht = Sheets("Sheet8")
  With Sht
    Set R = .Range(.Range("A2"), .Cells(.Cells.Rows.Count, 1).End(xlUp))    'Column A Data
    Set BotRow = .Range(.Cells(.Cells.Rows.Count, 1).End(xlUp), .Cells(.Cells.Rows.Count, 1).End(xlUp).Offset(0, 3)) 'Bottom of data
  End With
  
  For Each Cel In R
    If Not u Is Nothing Then
      If Not Intersect(Cel, u) Is Nothing Then GoTo NextCell                'This row is already slated to be deleted
    End If
    PCode = Cel.Offset(0, 3).Value
    Set PCodeRng = Sht.Range(Cel.Offset(0, 3), Intersect(Cel.Offset(0, 3).EntireColumn, BotRow))
    PCCnt = Application.CountIf(PCodeRng, PCode)
    If PCCnt > 0 Then                                                       'More than one pcode
      Set CostRng = Sht.Range(Cel.Offset(0, 2), Intersect(Cel.Offset(0, 2).EntireColumn, BotRow)) 'Add this row also
      Set ProdRng = Sht.Range(Cel.Offset(1, 1), Intersect(Cel.Offset(0, 1).EntireColumn, BotRow)) 'Start with row below
      TotalCost = Application.SumIfs(CostRng, PCodeRng, PCode)
      AccGrp = Cel.Value
      If Not u Is Nothing Then                                              'Add This row to be deleted
        Set u = Union(u, Cel.EntireRow)
      Else
        Set u = Cel.EntireRow
      End If
      ProdStr = Cel.Offset(0, 1).Value                                                      'Add product code to string
      X = 1
      For Each CC In ProdRng
        If CC.Offset(0, 2).Value = PCode Then
          ProdStr = ProdStr & ", " & CC.Value                               'Add next product code to string
          Set u = Union(u, CC.EntireRow)
          X = X + 1
          If X = PCCnt Then Exit For
        End If
      Next CC
      
      Set CC = Sht.Cells(Sht.Cells.Rows.Count, 1).End(xlUp).Offset(1, 0)    'Row Below all data
      CC.Value = AccGrp                                                     'Add new row with summarized data
      CC.Offset(0, 1).Value = ProdStr
      CC.Offset(0, 2).Value = TotalCost
      CC.Offset(0, 3).Value = PCode
    End If
NextCell:
  Next Cel
  If Not u Is Nothing Then
    u.EntireRow.Delete
  End If

  
End Sub
 
Upvote 0
Jeffrey Mahoney said:
Sorry, I couldn't help myself. I tested it on your data. You may want to test it further.

VBA Code: 
Sub Summarize()
  Dim Cel As Range
  Dim R As Range
  Dim u As Range
  Dim CC As Range
  Dim RR As Range
  Dim Sht As Worksheet
  Dim PCode As String
  Dim PCodeRng As Range
  Dim BotRow As Range
  Dim TotalCost As Double
  Dim CostRng As Range
  Dim ProdStr As String
  Dim ProdRng As Range
  Dim AccGrp As String
  Dim Pu As Range
  Dim PCCnt As Long
  Dim X As Long
 
  Set Sht = Sheets("Sheet8")
  With Sht
    Set R = .Range(.Range("A2"), .Cells(.Cells.Rows.Count, 1).End(xlUp))    'Column A Data
    Set BotRow = .Range(.Cells(.Cells.Rows.Count, 1).End(xlUp), .Cells(.Cells.Rows.Count, 1).End(xlUp).Offset(0, 3)) 'Bottom of data
  End With
 
  For Each Cel In R
    If Not u Is Nothing Then
      If Not Intersect(Cel, u) Is Nothing Then GoTo NextCell                'This row is already slated to be deleted
    End If
    PCode = Cel.Offset(0, 3).Value
    Set PCodeRng = Sht.Range(Cel.Offset(0, 3), Intersect(Cel.Offset(0, 3).EntireColumn, BotRow))
    PCCnt = Application.CountIf(PCodeRng, PCode)
    If PCCnt > 0 Then                                                       'More than one pcode
      Set CostRng = Sht.Range(Cel.Offset(0, 2), Intersect(Cel.Offset(0, 2).EntireColumn, BotRow)) 'Add this row also
      Set ProdRng = Sht.Range(Cel.Offset(1, 1), Intersect(Cel.Offset(0, 1).EntireColumn, BotRow)) 'Start with row below
      TotalCost = Application.SumIfs(CostRng, PCodeRng, PCode)
      AccGrp = Cel.Value
      If Not u Is Nothing Then                                              'Add This row to be deleted
        Set u = Union(u, Cel.EntireRow)
      Else
        Set u = Cel.EntireRow
      End If
      ProdStr = Cel.Offset(0, 1).Value                                                      'Add product code to string
      X = 1
      For Each CC In ProdRng
        If CC.Offset(0, 2).Value = PCode Then
          ProdStr = ProdStr & ", " & CC.Value                               'Add next product code to string
          Set u = Union(u, CC.EntireRow)
          X = X + 1
          If X = PCCnt Then Exit For
        End If
      Next CC
     
      Set CC = Sht.Cells(Sht.Cells.Rows.Count, 1).End(xlUp).Offset(1, 0)    'Row Below all data
      CC.Value = AccGrp                                                     'Add new row with summarized data
      CC.Offset(0, 1).Value = ProdStr
      CC.Offset(0, 2).Value = TotalCost
      CC.Offset(0, 3).Value = PCode
    End If
NextCell:
  Next Cel
  If Not u Is Nothing Then
    u.EntireRow.Delete
  End If

 
End Sub
Click to expand...
Many thanks @Jeffrey Mahoney for your quick reply.

I have run the code on my data but I got Run-Time error '13': Type mismatch. When I debug - it pointes me to the following piece of code. I also have attached snip of this.

If CC.Offset(0, 2).Value = PCode Then

Can you kindly check.

Thanks.
 
Upvote 0
Hi
Try this code
VBA Code: 
Sub test()
    Dim a As Variant
    Dim i As Long
    Dim w As Variant
    a = Sheets("sheet1").Cells(1).CurrentRegion
    With CreateObject("scripting.dictionary")
        For i = 1 To UBound(a)
            If Not .exists(a(i, 1) & a(i, 4)) Then
                .Add a(i, 1) & a(i, 4), Array(a(i, 1), a(i, 2), a(i, 3), a(i, 4))
            Else
                w = .Item(a(i, 1) & a(i, 4)): w(1) = w(1) & "," & a(i, 2): w(2) = w(2) + a(i, 3)
                .Item(a(i, 1) & a(i, 4)) = w
            End If
        Next
        itm = .items
        Sheets("sheet1").Cells(UBound(a) + 2, 1).Resize(.Count, 4) = Application.Index(.items, 0, 0)
    End With

End Sub
 
Upvote 0
mohadin said:
Hi
Try this code
VBA Code: 
Sub test()
    Dim a As Variant
    Dim i As Long
    Dim w As Variant
    a = Sheets("sheet1").Cells(1).CurrentRegion
    With CreateObject("scripting.dictionary")
        For i = 1 To UBound(a)
            If Not .exists(a(i, 1) & a(i, 4)) Then
                .Add a(i, 1) & a(i, 4), Array(a(i, 1), a(i, 2), a(i, 3), a(i, 4))
            Else
                w = .Item(a(i, 1) & a(i, 4)): w(1) = w(1) & "," & a(i, 2): w(2) = w(2) + a(i, 3)
                .Item(a(i, 1) & a(i, 4)) = w
            End If
        Next
        itm = .items
        Sheets("sheet1").Cells(UBound(a) + 2, 1).Resize(.Count, 4) = Application.Index(.items, 0, 0)
    End With

End Sub
Click to expand...
Sorry, the new code seems to have Run time error too.

If Not .exists(a(i, 1) & a(i, 4)) Then

Attached for reference.

Really appreciate for your time and looking into this. Thanks.
 
Upvote 0
whassan said:
Many thanks @Jeffrey Mahoney for your quick reply.

I have run the code on my data but I got Run-Time error '13': Type mismatch. When I debug - it pointes me to the following piece of code. I also have attached snip of this.

If CC.Offset(0, 2).Value = PCode Then

Can you kindly check.

Thanks.
Click to expand...
Add this line of code and tell me what it says
VBA Code: 
For Each CC In ProdRng
        Debug.Print "Cell Value: " & CC.Offset(0, 2).Value & "  PCode: " & PCode  '<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
        If CC.Offset(0, 2).Value = PCode Then
 
Upvote 0
Jeffrey Mahoney said:
Add this line of code and tell me what it says
VBA Code: 
For Each CC In ProdRng
        Debug.Print "Cell Value: " & CC.Offset(0, 2).Value & "  PCode: " & PCode  '<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
        If CC.Offset(0, 2).Value = PCode Then
Click to expand...
HI mate, Run time error 13 Type mismatch again on the new line code added as highlighted by Debugger. I have attached screen snip for reference.
Is there something I am not doing right or there is data format issue in my data.

Debug.Print "Cell Value: " & CC.Offset(0, 2).Value & " PCode: " & PCode
 
Upvote 0
I needed to know the value of the cell CC.Offset(0, 2).Value and the value of PCode. Can you show the Immediate window results for the Debug.print line.
 
Upvote 0
Jeffrey Mahoney said:
I needed to know the value of the cell CC.Offset(0, 2).Value and the value of PCode. Can you show the Immediate window results for the Debug.print line.
Click to expand...
Thanks again. I've attached the screenshot of the immediate window screen.
 
Upvote 0
whassan said:
I've attached the screenshot of the immediate window screen.
Click to expand...
I have seen a number of references to you having attached screenshots but I have not been able to see any sign of anything being attached.
Can you try just copying and pasting in the images ? Unless Jeff can see it I don't know how he will be able to help you without it.
 
Upvote 0
You must log in or register to reply here.

Similar threads

R
  • Question
Lowest value in range of cells excluding this row
2
Replies
10
Views
251
Peter_SSs
Peter_SSs
P
  • Question
ListBox Click to textbox & delete row
Replies
0
Views
319
pure vito
P
H
  • Solved
Macro to display message end of Code where Col D contains blanks
Replies
7
Views
335
howard
H
Agnarr
  • Question
VBA code mix
Replies
1
Views
351
Joe4
Joe4
Agnarr
  • Question
VBA problem with creating new sheets
Replies
0
Views
341
Agnarr
Agnarr

Forum statistics

Threads
1,214,789
Messages
6,121,590
Members
449,039
Latest member
Arbind kumar

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top