Filter Column by Value, if dups Aggregate Rows to 1 Rows

Hi everyone,

I can really use help and appreciate it if anyone has an idea to the following

I am working with a spreadsheet that is raw data from a system, I need to aggregate rows of data if a condition is met.

Bassically, while filtering for dups, if it finds rows that are the same it would.
[1] SUM column E, display only the summed quantity in the new row.
[2] Column H, it would display the weighted average Value only.... To do this it would have to take SUMPRODUCT of (Column G x Column H) divided by SUM col E

Cannot do the weighted Average since no data in "G" - But this will get you the aggregate of all records with ID's:
Be sure to have backup before using

Sub Stein(): Dim P, Q, r As Long, s As Long, wa As Worksheet
Dim ID As String, n As Long, k As Long: s = 2
                Set wa = Sheets("Daily Input")
        If ActiveSheet.Name <> wa.Name Then Exit Sub
                    wa.AutoFilterMode = False
    P = wa.UsedRange: wa.UsedRange.Offset(1).ClearContents
    Q = wa.Cells(1, 1).Resize(UBound(P, 1), UBound(P, 2))
        With CreateObject("Scripting.Dictionary")
            For r = 2 To UBound(P, 1): ID = P(r, 33)
            If ID <> "" Then
        If .Exists(ID) Then
        k = .Item(ID): Q(k, 5) = Q(k, 5) + P(r, 5)
        Else: .Item(ID) = s
        For n = 1 To UBound(P, 2): Q(s, n) = P(r, n): Next n: s = s + 1
        End If: End If: Next r
        wa.Cells(1, 1).Resize(UBound(Q, 1), UBound(Q, 2)) = Q
        End With
End Sub

Wow thank you so much xladept! But I was wondering I need to do the weighted average, I meant to write column E this is where the Order Size is.... So I would need to be able to do SUMPRODUCT (col E, col H) / SUM col E ...

This uses G and AH for Average Price:

Sub Stein(): Dim P, Q, r As Long, s As Long, wa As Worksheet
Dim ID As String, n As Long, k As Long: s = 2
                Set wa = Sheets("Daily Input")
        If ActiveSheet.Name <> wa.Name Then Exit Sub
                    wa.AutoFilterMode = False
    P = wa.UsedRange: wa.UsedRange.Offset(1).ClearContents
    Q = wa.Cells(1, 1).Resize(UBound(P, 1), UBound(P, 2) + 1)
        With CreateObject("Scripting.Dictionary")
            For r = 2 To UBound(P, 1): ID = P(r, 33): P(r, 7) = P(r, 5) * P(r, 8)
            If ID <> "" Then
        If .Exists(ID) Then
        k = .Item(ID): Q(k, 5) = Q(k, 5) + P(r, 5): Q(k, 7) = Q(k, 7) + P(r, 7)
        Else: .Item(ID) = s
        For n = 1 To UBound(P, 2): Q(s, n) = P(r, n): Next n: s = s + 1
        End If: End If: Next r: k = s
        For r = 2 To s - 1: Q(r, 34) = Q(r, 7) / Q(r, 5): Next r
        wa.Cells(1, 1).Resize(UBound(Q, 1), UBound(Q, 2)) = Q
        End With
End Sub

Hi xladept, I can't thank you enough for showing me this. This is a really great way of doing it and really fast. I do want to mention the one flaw I need to figure out to make this work 100%. Right now it is not taking into account that if Column AH is blank, we want to keep this row, and only aggregate those with dups.... It is deleting rows where AH is blank.

Probably another column to aggregate the Total Price then another scan after the aggregates to get the average price.

Now try this:

Sub SteinIII(): Dim P, Q, r As Long, s As Long, wa As Worksheet
Dim ID As String, n As Long, k As Long: s = 2
                Set wa = Sheets("Daily Input")
        If ActiveSheet.Name <> wa.Name Then Exit Sub
                    wa.AutoFilterMode = False
    P = wa.Cells(1, 1).CurrentRegion: wa.UsedRange.Offset(1).ClearContents
    Q = wa.Cells(1, 1).Resize(UBound(P, 1), UBound(P, 2) + 1)
        With CreateObject("Scripting.Dictionary")
            For r = 2 To UBound(P, 1): ID = P(r, 33): P(r, 7) = P(r, 5) * P(r, 8)
            If ID <> "" Then
        If .Exists(ID) Then
        k = .Item(ID): Q(k, 5) = Q(k, 5) + P(r, 5): Q(k, 7) = Q(k, 7) + P(r, 7)
        Else: .Item(ID) = s
        For n = 1 To UBound(P, 2): Q(s, n) = P(r, n): Next n: s = s + 1
        End If
        Else
        For n = 1 To UBound(P, 2): Q(s, n) = P(r, n): Next n: s = s + 1
        End If: Next r: k = s
        For r = 2 To s - 1: Q(r, 34) = Q(r, 7) / Q(r, 5): Next r
        wa.Cells(1, 1).Resize(UBound(Q, 1), UBound(Q, 2)) = Q
        End With
End Sub

You're welcome and thanks for the rep!

@ xladept,

I like, WOW!

@ Winon - Thanks, I copied the input 15 times and found out about using CurrentRegion when the input was filled with blanks

Hi xladept, I implemented this on my real data set and I realized that the columns weren't positioned entirely right from my sample you worked on. Usually this isn't an issue as I would change it myself, however Col 7 which is the blank column in the sample you were putting (price x quantity) actually has data, so I tried replacing 7 int he code to 36 with hopes of shifting this calculation out of the way, but when I do this the code breaks, I can't figure out why... All the other changes to columns I did work just this one. Would be awesome to get your input I am sure it takes 2secs as all the heavy lifting is done...

A new sample sheet is attached with the right columns in the right spots as my real data.

Bassically here are the changes that you will see in the sample sheet:
Parent Order ID: code references column 33 in reality should reference column 34
Quantity: code references column 5 in reality should reference column 11
Column 34 where you put the calculated weighted average price, I pushed it over to 35 since Order ID is there
---
to date all these changes work besides this last one:
Column 7: you used it in the code to put a calculation, in reality the dataset has a description there, I replaced col 7 for col 36 in your code and code doesnt work

Any way you can kindly suggest how I can implement your code to the enwly attached spreadsheet?

Try this:

Sub SteinIII(): Dim P, Q, r As Long, s As Long, wa As Worksheet
Dim ID As String, n As Long, k As Long: s = 2
                Set wa = Sheets("Daily Input")
        If ActiveSheet.Name <> wa.Name Then Exit Sub
                    wa.AutoFilterMode = False
    P = wa.Cells(1, 2).CurrentRegion: wa.UsedRange.Offset(1).ClearContents
    Q = wa.Cells(1, 1).Resize(UBound(P, 1), UBound(P, 2) + 1)
        With CreateObject("Scripting.Dictionary")
            For r = 2 To UBound(P, 1): ID = P(r, 34): P(r, 5) = P(r, 11) * P(r, 8)
            If ID <> "" Then
        If .Exists(ID) Then
        k = .Item(ID): Q(k, 5) = Q(k, 5) + P(r, 5): Q(k, 11) = Q(k, 11) + P(r, 11)
        Else: .Item(ID) = s
        For n = 1 To UBound(P, 2): Q(s, n) = P(r, n): Next n: s = s + 1
        End If
        Else
        For n = 1 To UBound(P, 2): Q(s, n) = P(r, n): Next n: s = s + 1
        End If: Next r: k = s
        For r = 2 To s - 1: Q(r, 35) = Q(r, 5) / Q(r, 11): Next r
        wa.Cells(1, 1).Resize(UBound(Q, 1), UBound(Q, 2)) = Q
        End With
End Sub

Ah man I really wish I double checked what I uploaded. I see you changed it to column 5 now, essentially this gives me the same problem, im sure its one little tweak and were good to go but if you check now the spreadsheet you will see that there is data in col 5 too. The reason some columns were blank was because I was desensitizing it and removing data, essentially any extra calculations we do with the macro needs to be after column 35, or else its overwritting data (price and volume is okay though since we want to overwrite that).

I know I am starting to grind your gears, but would really appreciate it if you had a last look at the ammendmend I just did,the code breaks in the same spot and I am busting my head trying to figure out why... Sorry I didn't explain so well the first time, if you check the sample sheet now it will be clear.

I changed 5 to 37 and the column for price... and it won't work

Sub SteinIII(): Dim P, Q, r As Long, s As Long, wa As Worksheet
Dim ID As String, n As Long, k As Long: s = 2
                Set wa = Sheets("Daily Input")
        If ActiveSheet.Name <> wa.Name Then Exit Sub
                    wa.AutoFilterMode = False
    P = wa.Cells(1, 2).CurrentRegion: wa.UsedRange.Offset(1).ClearContents
    Q = wa.Cells(1, 1).Resize(UBound(P, 1), UBound(P, 2) + 1)
        With CreateObject("Scripting.Dictionary")
            For r = 2 To UBound(P, 1): ID = P(r, 34): P(r, 37) = P(r, 11) * P(r, 13)
            If ID <> "" Then
        If .Exists(ID) Then
        k = .Item(ID): Q(k, 37) = Q(k, 37) + P(r, 37): Q(k, 11) = Q(k, 11) + P(r, 11)
        Else: .Item(ID) = s
        For n = 1 To UBound(P, 2): Q(s, n) = P(r, n): Next n: s = s + 1
        End If
        Else
        For n = 1 To UBound(P, 2): Q(s, n) = P(r, n): Next n: s = s + 1
        End If: Next r: k = s
        For r = 2 To s - 1: Q(r, 35) = Q(r, 37) / Q(r, 11): Next r
        wa.Cells(1, 1).Resize(UBound(Q, 1), UBound(Q, 2)) = Q
        End With
End Sub

Adding the new columns at the end required that we initialize them in order to establish the array bounds - try this:

Sub SteinIII(): Dim P, Q, r As Long, s As Long, wa As Worksheet
Dim ID As String, n As Long, k As Long: s = 2
                Set wa = Sheets("Daily Input")
        If ActiveSheet.Name <> wa.Name Then Exit Sub
                    wa.AutoFilterMode = False
        wa.Cells(1, 35) = "Avg": wa.Cells(1, 36) = "Agg"
          wa.Columns("AI:AJ").NumberFormat = "0.00"
    P = wa.Cells(1, 2).CurrentRegion: wa.UsedRange.Offset(1).ClearContents
    Q = wa.Cells(1, 1).Resize(UBound(P, 1), UBound(P, 2))
        With CreateObject("Scripting.Dictionary")
            For r = 2 To UBound(P, 1): ID = P(r, 34): P(r, 36) = P(r, 11) * P(r, 8)
            If ID <> "" Then
        If .Exists(ID) Then
        k = .Item(ID): Q(k, 36) = Q(k, 36) + P(r, 36): Q(k, 11) = Q(k, 11) + P(r, 11)
        Else: .Item(ID) = s
        For n = 1 To UBound(P, 2): Q(s, n) = P(r, n): Next n: s = s + 1
        End If
        Else
        For n = 1 To UBound(P, 2): Q(s, n) = P(r, n): Next n: s = s + 1
        End If: Next r: k = s
        For r = 2 To s - 1: Q(r, 35) = Q(r, 36) / Q(r, 11): Next r
        wa.Cells(1, 1).Resize(UBound(Q, 1), UBound(Q, 2)) = Q
        End With
End Sub