VBA code to Sum duplicate values then delete duplicate rows

whassan · Dec 8, 2021

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

AccountingGroup		Mon 06-Dec-21
321_AFS	PRODUCT 1	39,400.00	XS2395583995
321_AFS	PRODUCT 2	67,800.00	XS2395583995
321_AFS	PRODUCT 3	67,800.00	XS2395583995
321_AFS	PRODUCT 4	29,500.00	XS2395584456
321_AFS	PRODUCT 5	67,400.00	XS2395584456
321_AFS	PRODUCT 6	2,000.00	XS2395584456
321_AFS	PRODUCT 7	9,100.00	XS2395584456

After:

Col A Col B Col C Col D

AccountingGroup		Mon 06-Dec-21
321_AFS	PRODUCT 1, PRODUCT 2, PRODUCT 3	175,000.00	XS2395583995
321_AFS	PRODUCT 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

Jeffrey Mahoney · Dec 8, 2021

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

whassan · Dec 9, 2021

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

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.

mohadin · Dec 9, 2021

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

whassan · Dec 9, 2021

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

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.

Jeffrey Mahoney · Dec 9, 2021

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.

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

whassan · Dec 9, 2021

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

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

Jeffrey Mahoney · Dec 9, 2021

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.

whassan · Dec 10, 2021

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.

Thanks again. I've attached the screenshot of the immediate window screen.

Alex Blakenburg · Dec 10, 2021

whassan said:
I've attached the screenshot of the immediate window screen.

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.

VBA code to Sum duplicate values then delete duplicate rows

whassan

New Member

Excel Facts

Jeffrey Mahoney

Well-known Member

whassan

New Member

mohadin

Well-known Member

whassan

New Member

Jeffrey Mahoney

Well-known Member

whassan

New Member

Jeffrey Mahoney

Well-known Member

whassan

New Member

Alex Blakenburg

MrExcel MVP

Similar threads

Forum statistics

Share this page

VBA code to Sum duplicate values then delete duplicate rows

New Member

Excel Facts

Well-known Member

New Member

Well-known Member

New Member

Well-known Member

New Member

Well-known Member

New Member

MrExcel MVP

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock