Total duplicate rows

Question

So I know this question has been asked time and time again, but going through all the posts and creating code, I can't seem to get mine to work. I've attached an example of what my data looks like and what I need it to look like. My issue is the code is pasting the first column, which I don't want, and it isn't adding all the duplicate rows together.

what data looks like (Data), needs to look like (Need), and is coming out as(Get):

The code I have tried is the following:

Dim ar As Variant
Dim i As Long
Dim j As Long
Dim n As Long
Dim str As String

n = 2
ar = Worksheets("bom_wo_header").Cells(4, 1).CurrentRegion.value
With CreateObject("Scripting.Dictionary")
    For i = 3 To UBound(ar, 1)
        str = ar(i, 5)
        If Not .exists(str) Then
            n = n + 1
            For j = 1 To UBound(ar, 2)
                ar(n, j) = ar(i, j)
            Next j
            .Item(str) = n
        Else
            j = 3
            ar(.Item(str), j) = ar(.Item(str), j) + ar(i, j)
        End If
    Next i
End With
Worksheets("totals").Range("A1").Resize(n, UBound(ar, 2)).value = ar

Also, please read this - https://meta.stackoverflow.com/questions/285551/why-not-upload-images-of-code-on-so-when-asking-a-question — Sajan, Apr 28 '20 at 17:16

AKdelBosque · Accepted Answer · 2020-04-28T15:03:47.800

Your code is much more dynamic, but given the way your data is presented you may not need to account for so many things.

This is what I did and got your desired result. Change/add your ranges as necessary.

Sub Unique_List_Sum()

'First generate unique list for products**************

Dim X
Dim objDict As Object
Dim lngRow As Long
Dim r As Range

Set objDict = CreateObject("Scripting.Dictionary")
X = Application.Transpose(Range([B1], Cells(Rows.Count, "B").End(xlUp)))

For lngRow = 1 To UBound(X, 1)
    objDict(X(lngRow)) = 1
Next
Range("E1:E" & objDict.Count) = Application.Transpose(objDict.keys)

'Secont sumif each unique*****************

Set r = ActiveSheet.Range("E2:E" & objDict.Count) 'no need to sum "Product"

For Each prod In r

'end loop at blank cell
    If prod = "" Then
        Exit For
            End If

prod.Offset(0, 1).Value = Application.WorksheetFunction.SumIf(Range("B:B"), prod, Range("A:A"))

Next prod


End Sub

Unique list method credit: Populate unique values into a VBA array from Excel user brettdj

****** If your screenshot value "Data:" is in cell A1, change your tab names to "Madds Data" and "Madds Output" and this will run for you:

Sub Madds_Dups()

Sheets("Madds Data").Select
Range("E:E").Copy Destination:=Sheets("Madds Output").Range("A1")
Sheets("Madds Output").Range("A:A").RemoveDuplicates Columns:=1, Header:=xlNo
Sheets("Madds Output").Select

'delete blank row
Rows("1:1").Select
Selection.Delete shift:=xlUp

'Loop sums
Set r = ActiveSheet.Range("A2:A1000")

For Each prod In r

'end loop at blank cell
    If prod = "" Then
        Exit For
            End If

prod.Offset(0, 1).Value = Application.WorksheetFunction.SumIf(Sheets("Madds Data").Range("E:E"), prod, Sheets("Madds Data").Range("C:C"))

Next prod

End Sub

AKow, I have to modify the code so the results show up in a different sheet, which I probably should have specified in my question. I've managed to do it for the product portion. I am, however, struggling to figure out how to modify the code to get the summed quantities to show up on the second sheet. — Madds, Apr 28 '20 at 13:50
@Madds You'll just need to adjust the ranges the code is running through. I added a Sheet2 to my book and had it put the output in columns A and B. See my adds in the answer. Please hit the up arrow if this is helpful, and/or the check if this solved your problem :D — AKdelBosque, Apr 28 '20 at 14:03
@Madds I modified again for you and it should work exactly as your data is. The first part of my answer didn't account for the blanks in your presentation. So, if that's always how your data is formatted, I would select the entire row and remove duplicates to get a unique list. If its a large data set it won't run very fast, but for what you've got its fine. — AKdelBosque, Apr 28 '20 at 15:05

Total duplicate rows

1 Answers1