Find Duplicate, sum qty column, delete rest of duplicates

[colaps]

Hello,

I`m working on a big raw data file and i need to have sum of duplicates.

The file normally has around 16000+ rows and 50 columns. I need to have a VBA code that searches for duplicates, if finding them , adds up the qty and deletes all other duplicates .

I have a working code found on this forum but the issue is speed. Not sure if the first developer of the code had multiple possible duplicates but in my case i have to loop again again and again until no duplicates are found. For 4000+ test rows it took me around 6 minutes ... Can you please propose me a better solution?

Here is a semple of my data:

UniqueID	NetPrice	GrossPrice	Qty-KE
2001	3998	3944	303
2103	5048	145	374
2212	126	3344	910
1872	4421	5313	934
4512	3696	3732	258
2545	2743	5961	214
3356	3028	1737	545
2356	257	1682	1025
5489	3721	4976	1076
3256	6109	3638	729
3256	1711	2855	441
5841	3758	6349	1187
3256	2693	2317	73
1254	610	2465	201
1287	2662	339	940
3256	2101	1515	303
0	662	6862	558
2212	4097	2574	628
2212	2714	4419	1096
5687	1449	2861	960
9526	3943	4713	648
2695	69	4500	734
9595	770	4242	199
9536	1771	701	359
3656	2334	3021	993
8787	1336	4623	747
8787	5090	1688	364
8787	7160	1388	936
5415	5477	1309	739
1585	7165	2474	282
8987	3823	6007	852
5689	3385	6787	1070
5654	3580	270	927
1254	1153	2182	721
3256	4441	3389	1162

*Highlighted in red are the duplicates

And here is the code i`m using:
author : Sum and remove duplicate rows

Sub noDupes()

Dim Cell As Variant
Dim Source As Range
Dim lRow As Long, k As Long, i As Long, q As Long
Dim fullstr As String, fullstr2 As String
Dim arr As Variant
ReDim arr(0)

lRow = Cells(Rows.Count, 1).End(xlUp).Row


Set Source = Range(Cells(2, 1), Cells(lRow, 1))


For Each Cell In Source
   
    If Application.WorksheetFunction.CountIf(Source, Cell) > 1 Then
       
            For k = 2 To lRow Step 1
        fullstr = Cells(k, 1)
        For i = 2 To lRow Step 1
            fullstr2 = Cells(i, 1)
            If k <> i And k < i Then
                If fullstr = fullstr2 And fullstr <> "" Then
                    Cells(k, 5).value = (Cells(k, 4).value + Cells(i, 4).value)
                    Cells(k, 4).value = Cells(k, 5).value
                    arr(UBound(arr)) = i
                    ReDim Preserve arr(UBound(arr) + 1)
                    Range("A" & i).EntireRow.Delete
                End If
            End If
        Next
    Next

       
    End If
Next

Any help is weclomed.

Thank you.

 

[Fluff]

That code is nothing like the code you have pointed to.
Did you actually try the other code?

 

[colaps]

That code is nothing like the code you have pointed to.
Did you actually try the other code?

Ouch, you are right, i linked the wrong code. I will try now the code you posted.

sorry.

 

[Fluff]

If you have any problems, just shout.

 

[colaps]

@Fluff Your code is working just fine for me ! Thanks, my problem is solved.

 

[Fluff]

Glad you sorted it & thanks for the feedback.