VBA to Sum and Delete Duplicate Values

[jrjobe]

Hi All!

I am trying to figure out a way to sum only the values in column B based on all duplicates from column A, then delete all duplicate rows, while retaining rows that do not have a duplicate. What I initially came up with was from another thread, but after modifying the code, it still leaves the duplicates, but also adds the duplicate names to column C, basically duplicating the name multiple times. Here is an example of what I'm trying to combine, not all items are duplicates:

***BOM***	Quantity	Description	T/R
3287796	10	ELCO EL490ICA 4INIC AT HSNG FOR LED RTFT
3287796	10	ELCO EL490ICA 4INIC AT HSNG FOR LED RTFT
38718	300	WIRE NM-B-14/2-CU-WG-250
12704	10	DOTTIE BX1005 BX STAPLE
4600929	10	ELCO EL416CT5W 4 IN GIMBAL LED SELECTABLE CCT INSERT
3287796	10	ELCO EL490ICA 4INIC AT HSNG FOR LED RTFT
38718	300	WIRE NM-B-14/2-CU-WG-250
12704	10	DOTTIE BX1005 BX STAPLE
4600927	54	ELCO EL616CT5W 5/6 IN GIMBAL LED SELECTABLE CCT INSERT
3332826	54	ELCO EL570ICA
38718	1620	WIRE NM-B-14/2-CU-WG-250
12704	54	DOTTIE BX1005 BX STAPLE
4302051	25	NIC DSK43120SWH 9.1W DNL FX 4 AC DISK
4435389	25	ALLIED 9351-N 4-IN ROUND OUTLET BOX
38718	750	WIRE NM-B-14/2-CU-WG-250
12704	25	DOTTIE BX1005 BX STAPLE
3287796	25	ELCO EL490ICA 4INIC AT HSNG FOR LED RTFT
3287796	25	ELCO EL490ICA 4INIC AT HSNG FOR LED RTFT
38718	750	WIRE NM-B-14/2-CU-WG-250
12704	25	DOTTIE BX1005 BX STAPLE
4219304	245	SYL (61404) LEDMD4R/2A/800ST/9SC3/61404
38718	7350	WIRE NM-B-14/2-CU-WG-250
12704	245	DOTTIE BX1005 BX STAPLE
4219305	54	SYL (61405) LEDMD6R/2A/1200ST/9SC3
38718	1620	WIRE NM-B-14/2-CU-WG-250
12704	54	DOTTIE BX1005 BX STAPLE
1149384	28	CCHO TP267 4IN RND CEIL PAN NOT FAN RTD
38718	840	WIRE NM-B-14/2-CU-WG-250
12704	28	DOTTIE BX1005 BX STAPLE

Here's the code I am using - probably not the most efficient, so I am definitely open to something else.

Sub SumandRemove() 'Excel VBA code to sum rows and remove duplicates.
    Dim ar   As Variant
    Dim i    As Long
    Dim b    As Long
    Dim d    As Long
    Dim str  As String
    Dim Col  As Collection
    
    d = 1
    ar = Sheet5.Cells(2, 1).CurrentRegion.Value
    Set Col = New Collection
    With Col
        For i = 2 To UBound(ar, 1)
            str = ar(i, 1) 'The unique value is in the 1st column
            If Not Exists(Col, str) Then
                d = d + 1
                For b = 1 To UBound(ar, 2)
                    ar(d, b) = ar(i, b)
                Next b
            .Add d, str
            Else
                For b = 2 To UBound(ar, 2) 'the number column is start Column 2
                    ar(.Item(str), b) = ar(.Item(str), b) + ar(i, b)
                Next b
            End If
        Next i
    End With
    Sheet5.Range("A2").Resize(d, UBound(ar, 2)).Value = ar
End Sub

' http://www.vbaexpress.com/forum/showthread.php?26312-Solved-Test-if-an-item-exists-within-a-collection-data-type
Function Exists(Col, ByVal Key As String) As Boolean
    On Error GoTo NotExists
    If VarType(Col.Item(Key)) = vbObject Then
    End If
    Exists = True
    Exit Function
NotExists:
    Exists = False
End Function

Thank you for the help!

 

[jrjobe]

Thanks all for the help and I apologize for the late reply! The reason I haven't used Power Query is that I am far from familiar with it and use quite a bit of VBA tied to a custom menu built using Office RibbonX Editor. Up until I finally decided to get some assistance, I did use Pivot Tables to do something similar. It was kind of a pain and not quite as streamlined as clicking a button as I can do with other actions on the workbook.

@alansidman I'll take a deeper look into PQ based on your comments and recommendations by @kevin9999. I guess it is good to learn something new.

@Peter_SSs - I had been contemplating the order of those numbers as they are item numbers from another worksheet. The other worksheet has over 70K line items, but the numbers aren't consecutive, yet they are in order. It's really for internal use only though.

@mohadin - thanks for this input as well! It works similarly to the Pivot Table - not certain I like it that way though as I do have another button prepped to generate a PDF on this page of the cleaned-up data. The benefit to this or the Pivot Table is that both allow me to check the items to ensure nothing is missing. Although, multiple runs of various data, show nothing is missing and is combining as it should. I'll keep this in the workbook in case we run into a problem and need to start double-checking the data.

Again, I can't thank y'all enough!

 

[alansidman]

Thanks for the feedback