VBA to merge duplicate rows and sum values in certain column

[mwstorms21]

Hello,
I am new to this forum, but ran across MickG's code for using VBA to merge duplicate rows and sum values in certain column. I was hoping someone might be able to help me edit this code to suit my needs.
The original thread is here: VBA to merge duplicate rows and sum values in certain column

The following data (headers titles) starts on row 12 of my spreadsheet. (row 13 is the first row that I want to process)

I would like to identify unique values in column 5 ("Description"), delete duplicate rows, and sum column 6 ("Quantity") while leaving the other columns (1,2,3,4,7,8,9,10) unchanged.

Thank you so much for your help and please let me know if there is any other information I need to provide.

Line	Price List	Part Number	Manufacturer	Description	Quantity	Pro-Rated Price	Extended Price	Start Date	End Date
1	PRICE LIST 123	PART1	ManufacturerA	Annual Maintenance for Apple iPad including: 365 days unlimited Verizon data plan (DTL at 15GB)	1	$ 400.00	$ 400.00	9/11/2020	9/11/2021
2	PRICE LIST 123	PART1	ManufacturerA	Annual Maintenance for Apple iPad including: 365 days unlimited Verizon data plan (DTL at 15GB)	1	$ 400.00	$ 400.00	9/12/2020	9/11/2021
3	PRICE LIST 123	PART1	ManufacturerA	Annual Maintenance for Apple iPad including: 365 days unlimited Verizon data plan (DTL at 15GB)	1	$ 400.00	$ 400.00	9/12/2020	9/11/2021
4	PRICE LIST 123	PART1	ManufacturerA	Annual Maintenance for Apple iPad including: 283 days unlimited Verizon data plan (DTL at 15GB)	1	$ 300.00	$ 300.00	12/3/2020	9/11/2021
5	PRICE LIST 123	PART1	ManufacturerA	Annual Maintenance for Apple iPad including: 283 days unlimited Verizon data plan (DTL at 15GB)	1	$ 300.00	$ 300.00	12/3/2020	9/11/2021
6	PRICE LIST 123	PART1	ManufacturerA	Annual Maintenance for Apple iPad including: 283 days unlimited Verizon data plan (DTL at 15GB)	1	$ 300.00	$ 300.00	12/3/2020	9/11/2021
7	PRICE LIST 123	PART1	ManufacturerA	Annual Maintenance for Apple iPad including: 283 days unlimited Verizon data plan (DTL at 15GB)	1	$ 300.00	$ 300.00	12/3/2020	9/11/2021
8	PRICE LIST 123	PART1	ManufacturerA	Annual Maintenance for Apple iPad including: 162 days unlimited Verizon data plan (DTL at 15GB)	1	$ 200.00	$ 200.00	4/3/2021	9/11/2021
9	PRICE LIST 123	PART1	ManufacturerA	Annual Maintenance for Apple iPad including: 162 days unlimited Verizon data plan (DTL at 15GB)	1	$ 200.00	$ 200.00	4/3/2021	9/11/2021
10	PRICE LIST 123	PART1	ManufacturerA	Annual Maintenance for Apple iPad including: 162 days unlimited Verizon data plan (DTL at 15GB)	1	$ 200.00	$ 200.00	4/3/2021	9/11/2021
11	PRICE LIST 123	PART1	ManufacturerA	Annual Maintenance for Apple iPad including: 155 days unlimited Verizon data plan (DTL at 15GB)	1	$ 150.00	$ 200.00	4/10/2021	9/11/2021
12	PRICE LIST 123	PART1	ManufacturerA	Annual Maintenance for Apple iPad including: 137 days unlimited Verizon data plan (DTL at 15GB)	1	$ 100.00	$ 100.00	4/28/2021	9/11/2021
13	PRICE LIST 123	PART1	ManufacturerA	Annual Maintenance for Apple iPad including: 137 days unlimited Verizon data plan (DTL at 15GB)	1	$ 100.00	$ 100.00	4/28/2021	9/11/2021
14	PRICE LIST 123	PART1	ManufacturerA	Annual Maintenance for Apple iPad including: 137 days unlimited Verizon data plan (DTL at 15GB)	1	$ 100.00	$ 100.00	4/28/2021	9/11/2021
15	PRICE LIST 123	PART1	ManufacturerA	Annual Maintenance for Apple iPad including: 137 days unlimited Verizon data plan (DTL at 15GB)	1	$ 100.00	$ 100.00	4/28/2021	9/11/2021

 

[mwstorms21]

I should also note that there are not always 15 rows that I want to process. The number of rows will vary between just a few to sometimes hundreds of rows. Thanks again!

 

[DanteAmor]

Try this:

Sub merge_duplicate()
  Dim Rng As Range, Dn As Range, nRng As Range
  Dim n As Long, lr As Long, Txt As String

  Application.ScreenUpdating = False

  lr = Range("E" & Rows.Count).End(3).Row
  Set Rng = Range("E13:E" & lr)
  Set nRng = Range("E" & lr + 1)

  With CreateObject("scripting.dictionary")
    .CompareMode = vbTextCompare
 
    For Each Dn In Rng
      Txt = Dn.Value
      If Not .Exists(Txt) Then
        .Add Txt, Dn.Offset(, 1)
      Else
        .Item(Txt).Value = .Item(Txt).Value + Dn.Offset(, 1).Value
        Set nRng = Union(nRng, Dn)
      End If
    Next
 
    nRng.EntireRow.Delete
  End With

  Application.ScreenUpdating = True
End Sub

 

[mwstorms21]

Try this:

Sub merge_duplicate()
  Dim Rng As Range, Dn As Range, nRng As Range
  Dim n As Long, lr As Long, Txt As String

  Application.ScreenUpdating = False

  lr = Range("E" & Rows.Count).End(3).Row
  Set Rng = Range("E13:E" & lr)
  Set nRng = Range("E" & lr + 1)

  With CreateObject("scripting.dictionary")
    .CompareMode = vbTextCompare

    For Each Dn In Rng
      Txt = Dn.Value
      If Not .Exists(Txt) Then
        .Add Txt, Dn.Offset(, 1)
      Else
        .Item(Txt).Value = .Item(Txt).Value + Dn.Offset(, 1).Value
        Set nRng = Union(nRng, Dn)
      End If
    Next

    nRng.EntireRow.Delete
  End With

  Application.ScreenUpdating = True
End Sub

DanteAmor,
That worked really well! Thank you so much!

However, there is one issue that I hope you can help me solve. Just below the last row of data that I want processed, there is a formula that Subtotals, a row that calculates a fee, and row that totals those. (see image). Below those rows, there is also some terms and conditions/payment info. I need to apply this formula without deleting the rows that contain the Subtotal, Fee, Total and any of the Terms and conditions info at the bottom.

The code works great! The only issue is it seems to delete the rows that contain my subtotal, fee, total, terms/quote details info (rows 59-64) in the attached image. Oddly enough, it seems to leave the terms and conditions below that alone. (rows 65-67 in the image)

Appreciate your help so much!!!

 

[DanteAmor]

Change this line:

lr = Range("E" & Rows.Count).End(3).Row

For this:

lr = Range("F" & Rows.Count).End(3).Row

And try again.

 

[mwstorms21]

You are awesome Dante! This works great!

I'm not sure if it's against forum rules. But I would really like to send you a gift via PayPal for your help. Mods please chime in if this is against the rules.

What a wonderful community this is!

 

[DanteAmor]

The rules don't allow it, just feedback is enough.

 

[mwstorms21]

OK. Thank you again!

 

[jms3564]

Try this:

Sub merge_duplicate()
  Dim Rng As Range, Dn As Range, nRng As Range
  Dim n As Long, lr As Long, Txt As String

  Application.ScreenUpdating = False

  lr = Range("E" & Rows.Count).End(3).Row
  Set Rng = Range("E13:E" & lr)
  Set nRng = Range("E" & lr + 1)

  With CreateObject("scripting.dictionary")
    .CompareMode = vbTextCompare
 
    For Each Dn In Rng
      Txt = Dn.Value
      If Not .Exists(Txt) Then
        .Add Txt, Dn.Offset(, 1)
      Else
        .Item(Txt).Value = .Item(Txt).Value + Dn.Offset(, 1).Value
        Set nRng = Union(nRng, Dn)
      End If
    Next
 
    nRng.EntireRow.Delete
  End With

  Application.ScreenUpdating = True
End Sub

I tried using this on a similar excel sheet. I am looking at column A and wanting to add quantity in column I, which is 8 columns away. When it runs, instead of adding the quantity numbers together, they are just putting them together. So if there are 3 of the same number with quantity 1, instead of making it quantity 3 it is coming up with quantity 111. What am I missing?

Dim Rng As Range, Dn As Range, nRng As Range
Dim n As Long, lr As Long, Txt As String

Application.ScreenUpdating = False

lr = Range("A" & Rows.Count).End(3).Row
Set Rng = Range("A2:A" & lr)
Set nRng = Range("A" & lr + 1)
With CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare

For Each Dn In Rng
Txt = Dn.Value
If Not .Exists(Txt) Then
.Add Txt, Dn.Offset(, 8)
Else
.Item(Txt).Value = .Item(Txt).Value + Dn.Offset(, 8).Value
Set nRng = Union(nRng, Dn)
End If
Next

nRng.EntireRow.Delete
End With
Application.ScreenUpdating = True