VBA to Sum and Delete Duplicate Values

J

jrjobe

New Member
Joined
Feb 3, 2012
Messages
38
Office Version
  1. 365
  2. 2003 or older
Platform
  1. Windows
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***QuantityDescriptionT/R
328779610ELCO EL490ICA 4INIC AT HSNG FOR LED RTFT
328779610ELCO EL490ICA 4INIC AT HSNG FOR LED RTFT
38718300WIRE NM-B-14/2-CU-WG-250
1270410DOTTIE BX1005 BX STAPLE
460092910ELCO EL416CT5W 4 IN GIMBAL LED SELECTABLE CCT INSERT
328779610ELCO EL490ICA 4INIC AT HSNG FOR LED RTFT
38718300WIRE NM-B-14/2-CU-WG-250
1270410DOTTIE BX1005 BX STAPLE
460092754ELCO EL616CT5W 5/6 IN GIMBAL LED SELECTABLE CCT INSERT
333282654ELCO EL570ICA
387181620WIRE NM-B-14/2-CU-WG-250
1270454DOTTIE BX1005 BX STAPLE
430205125NIC DSK43120SWH 9.1W DNL FX 4 AC DISK
443538925ALLIED 9351-N 4-IN ROUND OUTLET BOX
38718750WIRE NM-B-14/2-CU-WG-250
1270425DOTTIE BX1005 BX STAPLE
328779625ELCO EL490ICA 4INIC AT HSNG FOR LED RTFT
328779625ELCO EL490ICA 4INIC AT HSNG FOR LED RTFT
38718750WIRE NM-B-14/2-CU-WG-250
1270425DOTTIE BX1005 BX STAPLE
4219304245SYL (61404) LEDMD4R/2A/800ST/9SC3/61404
387187350WIRE NM-B-14/2-CU-WG-250
12704245DOTTIE BX1005 BX STAPLE
421930554SYL (61405) LEDMD6R/2A/1200ST/9SC3
387181620WIRE NM-B-14/2-CU-WG-250
1270454DOTTIE BX1005 BX STAPLE
114938428CCHO TP267 4IN RND CEIL PAN NOT FAN RTD
38718840WIRE NM-B-14/2-CU-WG-250
1270428DOTTIE BX1005 BX STAPLE


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

VBA Code: 
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!
 

Excel Facts

Does the VLOOKUP table have to be sorted?
No! when you are using an exact match, the VLOOKUP table can be in any order. Best-selling items at the top is actually the best.
Sort by date Sort by votes
Is this what you are looking for. You did not show us an expected result so I am guessing at your needs.

***BOM***Total
328779680
3871813530
12704451
460092910
460092754
333282654
430205125
443538925
4219304245
421930554
114938428
 
Upvote 0
I do apologize - I got ahead of myself. You are on the right track though. Here is an expected output:

***BOM***QuantityDescriptionT/R
328779680ELCO EL490ICA 4INIC AT HSNG FOR LED RTFT
3871813530WIRE NM-B-14/2-CU-WG-250
12704451DOTTIE BX1005 BX STAPLE
460092910ELCO EL416CT5W 4 IN GIMBAL LED SELECTABLE CCT INSERT
460092754ELCO EL616CT5W 5/6 IN GIMBAL LED SELECTABLE CCT INSERT
333282654ELCO EL570ICA
430205125NIC DSK43120SWH 9.1W DNL FX 4 AC DISK
443538925ALLIED 9351-N 4-IN ROUND OUTLET BOX
4219304245SYL (61404) LEDMD4R/2A/800ST/9SC3/61404
421930554SYL (61405) LEDMD6R/2A/1200ST/9SC3
114938428CCHO TP267 4IN RND CEIL PAN NOT FAN RTD


All rows without duplicate values would be retained as well as the item description.
 
Upvote 0
Power Query
Load your table to PQ Editor
Power Query: 
let
    Source = Excel.CurrentWorkbook(){[Name="Table1"]}[Content],
    #"Removed Columns" = Table.RemoveColumns(Source,{"T/R"}),
    #"Changed Type" = Table.TransformColumnTypes(#"Removed Columns",{{"***BOM***", Int64.Type}, {"Quantity", Int64.Type}, {"Description", type text}}),
    #"Grouped Rows" = Table.Group(#"Changed Type", {"***BOM***"}, {{"Total", each List.Sum([Quantity]), type nullable number}})
in
    #"Grouped Rows"

Reload your table as a new query

Power Query: 
let
    Source = Excel.CurrentWorkbook(){[Name="Table1"]}[Content],
    #"Removed Columns" = Table.RemoveColumns(Source,{"T/R"}),
    #"Changed Type" = Table.TransformColumnTypes(#"Removed Columns",{{"***BOM***", Int64.Type}, {"Quantity", Int64.Type}, {"Description", type text}}),
    #"Grouped Rows" = Table.Group(#"Changed Type", {"***BOM***"}, {{"Total", each List.Sum([Quantity]), type nullable number}})
in
    #"Grouped Rows"

JOin the two tables

Power Query: 
let
    Source = Table.NestedJoin(Table1, {"***BOM***"}, #"Table1 (2)", {"***BOM***"}, "Table1 (2)", JoinKind.LeftOuter),
    #"Expanded Table1 (2)" = Table.ExpandTableColumn(Source, "Table1 (2)", {"Description"}, {"Table1 (2).Description"})
in
    #"Expanded Table1 (2)"

***BOM***TotalTable1 (2).Description
328779680ELCO EL490ICA 4INIC AT HSNG FOR LED RTFT
3871813530WIRE NM-B-14/2-CU-WG-250
12704451DOTTIE BX1005 BX STAPLE
460092910ELCO EL416CT5W 4 IN GIMBAL LED SELECTABLE CCT INSERT
460092754ELCO EL616CT5W 5/6 IN GIMBAL LED SELECTABLE CCT INSERT
333282654ELCO EL570ICA
430205125NIC DSK43120SWH 9.1W DNL FX 4 AC DISK
443538925ALLIED 9351-N 4-IN ROUND OUTLET BOX
4219304245SYL (61404) LEDMD4R/2A/800ST/9SC3/61404
421930554SYL (61405) LEDMD6R/2A/1200ST/9SC3
114938428CCHO TP267 4IN RND CEIL PAN NOT FAN RTD
 
Upvote 0
Another option.
VBA Code: 
Option Explicit
Sub One_Key_Multi_Items()
    Dim rng As Range, r As Range, txt As String
    Dim i As Long, j As Long, n As Long, ws As Worksheet, ar
    Set ws = Worksheets("Sheet5")                           '<<< *** change to actual sheet name ***
    Set rng = ws.Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
    ar = ws.Range("A1").CurrentRegion

    With CreateObject("scripting.dictionary")
        For Each r In rng
            txt = r.Value
            If Not .exists(txt) Then
                n = n + 1
                .Add txt, n
                For j = 1 To UBound(ar, 2)
                    ar(n, j) = r.Offset(, j - 1)
                Next j
            Else
                For i = 2 To UBound(ar, 2)
                    If IsNumeric(ar(.Item(txt), i)) Then
                        ar(.Item(txt), i) = ar(.Item(txt), i) + r.Offset(, i - 1)
                    Else
                        ar(.Item(txt), i) = ar(.Item(txt), i)
                    End If
                Next i
            End If
        Next r
    End With
     
    With ws
        .Range("A1").CurrentRegion.Offset(1).ClearContents
        .Range("A1").Resize(n, 3) = ar
    End With
End Sub
 
Upvote 0
Solution
Gents, thank you for the help! I am not familiar with PQ and wasn't quite certain how I was going to integrate it. The VBA code provided by Kevin works like a champ. I'll compare it to what I tried to see where I went wrong. I did make a few changes to the code I posted, but still couldn't get the expected output and it kept copying the first row. I get rusty when I'm not looking at this every day.

Again, thank you!
 
Upvote 0
Glad we could help & thanks for the feedback :)
It's worth learning Power Query, as you can see Alan's solution requires a lot less code (and is therefore easier to change/maintain).
 
Upvote 0
In case it is of any use and depending if order is important, perhaps Excel's built-in Pivot Table feature (used in tabular form) might be worth considering as a manual option?

jrjobe.xlsm
ABCDEFGH
1***BOM***QuantityDescriptionT/R***BOM***DescriptionSum of Quantity
2328779610ELCO EL490ICA 4INIC AT HSNG FOR LED RTFT12704DOTTIE BX1005 BX STAPLE451
3328779610ELCO EL490ICA 4INIC AT HSNG FOR LED RTFT38718WIRE NM-B-14/2-CU-WG-25013530
438718300WIRE NM-B-14/2-CU-WG-2501149384CCHO TP267 4IN RND CEIL PAN NOT FAN RTD28
51270410DOTTIE BX1005 BX STAPLE3287796ELCO EL490ICA 4INIC AT HSNG FOR LED RTFT80
6460092910ELCO EL416CT5W 4 IN GIMBAL LED SELECTABLE CCT INSERT3332826ELCO EL570ICA54
7328779610ELCO EL490ICA 4INIC AT HSNG FOR LED RTFT4219304SYL (61404) LEDMD4R/2A/800ST/9SC3/61404245
838718300WIRE NM-B-14/2-CU-WG-2504219305SYL (61405) LEDMD6R/2A/1200ST/9SC354
91270410DOTTIE BX1005 BX STAPLE4302051NIC DSK43120SWH 9.1W DNL FX 4 AC DISK25
10460092754ELCO EL616CT5W 5/6 IN GIMBAL LED SELECTABLE CCT INSERT4435389ALLIED 9351-N 4-IN ROUND OUTLET BOX25
11333282654ELCO EL570ICA4600927ELCO EL616CT5W 5/6 IN GIMBAL LED SELECTABLE CCT INSERT54
12387181620WIRE NM-B-14/2-CU-WG-2504600929ELCO EL416CT5W 4 IN GIMBAL LED SELECTABLE CCT INSERT10
131270454DOTTIE BX1005 BX STAPLE
14430205125NIC DSK43120SWH 9.1W DNL FX 4 AC DISK
15443538925ALLIED 9351-N 4-IN ROUND OUTLET BOX
1638718750WIRE NM-B-14/2-CU-WG-250
171270425DOTTIE BX1005 BX STAPLE
18328779625ELCO EL490ICA 4INIC AT HSNG FOR LED RTFT
19328779625ELCO EL490ICA 4INIC AT HSNG FOR LED RTFT
2038718750WIRE NM-B-14/2-CU-WG-250
211270425DOTTIE BX1005 BX STAPLE
224219304245SYL (61404) LEDMD4R/2A/800ST/9SC3/61404
23387187350WIRE NM-B-14/2-CU-WG-250
2412704245DOTTIE BX1005 BX STAPLE
25421930554SYL (61405) LEDMD6R/2A/1200ST/9SC3
26387181620WIRE NM-B-14/2-CU-WG-250
271270454DOTTIE BX1005 BX STAPLE
28114938428CCHO TP267 4IN RND CEIL PAN NOT FAN RTD
2938718840WIRE NM-B-14/2-CU-WG-250
301270428DOTTIE BX1005 BX STAPLE
PT
 
Upvote 0
FYI

Power Query is a free AddIn for Excel 2010 and 2013, and is built-in functionality from Excel 2016 onwards (where it is referred to as "Get & Transform Data").

It is a powerful yet simple way of getting, changing and using data from a broad variety of sources, creating steps which may be easily repeated and refreshed. I strongly recommend learning how to use Power Query - it's among the most powerful functionalities of Excel.

- Follow this link to learn how to install Power Query in Excel 2010 / 2013.

- Follow this link for an introduction to Power Query functionality.

- Follow this link for a video which demonstrates how to use Power Query code provided.
 
Upvote 0
Hi
Same as kevein but...
VBA Code: 
Sub test()
Dim a, w
Dim i&
a = Sheets("Sheet5").Cells(1).CurrentRegion
    With CreateObject("scripting.dictionary")
        For i = 1 To UBound(a)
            If a(i, 1) <> "" Then
                If Not .exists(a(i, 1)) Then
                .Add a(i, 1), Array(a(i, 1), a(i, 3), a(i, 2))
                Else
                w = .Item(a(i, 1)): w(2) = w(2) + a(i, 2): .Item(a(i, 1)) = w
                End If
        End If
    Next
Sheets("Sheet5").Cells(1, 5).Resize(.Count, 3) = Application.Index(.items, 0, 0)
End With
End Sub
 
Upvote 0
You must log in or register to reply here.

Similar threads

S
  • Question
Number duplicate values VBA
Replies
6
Views
425
sofas
S
M
  • Locked
  • Solved
found duplicate value in textbox and dont allow to insert column A
2
Replies
16
Views
637
abrahamdany20
A
M
  • Question
VBA Code - Run Code if cell value is not blank
Replies
0
Views
436
MHamid
M
J
  • Question
Copy Duplicate stock name from two sheets into new sheet
2
Replies
11
Views
684
Fluff
Fluff
R
  • Solved
VBA: Merging rows after a particular row, based off of matching entries in column
2
Replies
19
Views
551
Georgiboy
Georgiboy

Forum statistics

Threads
1,215,095
Messages
6,123,073
Members
449,093
Latest member
ripvw

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