Aggregate multiple rows of data to one if conditions are met

Hi gurus,

I am trying to aggregate raw data based on if Column 4, 9, 26, and 35 are the same values.

Basically if these columns contain the same values in multiple other rows it means they can be combined into 1 row. When combining, I need to make 2 changes to represent an acurate aggregation of the data. 1st Column 11's new value would be the SUM of all the values in "Volume". And 2nd, Column 13's new value would be a weighted average Price, so (SUMPRODUCT (array 1 = col 11, array 2 = col 13) divided by SUM Col 11). And all other data in the row would stay the same, simply only aggregating these two values and simply deleting the rest, leaving me with one row.

How can I do this? I am only moderate at VBA and this seems like it needs a scripting dictionary which I am unfamiliar how to build. Would tremendously appreciate anyone's help here.

Maybe it doesn't need a scripting dictionary, whatever the case I am open to anything to get this done

A desensitized spreadsheet is attached for your reference, in reality I am dealing with thousands of rows so really need to automate this

Have a bless day!

Try this:

Sub SteinV(): 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, 4) & "|" & P(r, 9) & "|" & P(r, 26) & "|" & P(r, 35)
            P(r, 13) = P(r, 11) * P(r, 13)
            If ID <> "" Then
        If .Exists(ID) Then
   k = .Item(ID): Q(k, 11) = Q(k, 11) + P(r, 11): Q(k, 13) = Q(k, 13) + P(r, 13)
        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, 13) = Q(r, 13) / Q(r, 11): Next r
        wa.Cells(1, 1).Resize(UBound(Q, 1), UBound(Q, 2)) = Q
        End With
End Sub

You're welcome and God Bless You too

I just changed some column numbers - see if it works:

Sub SteinVII_IP(): 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("Database (2)")
        If ActiveSheet.Name <> wa.Name Then Exit Sub
                    wa.AutoFilterMode = False
    P = wa.Cells(3, 1).CurrentRegion: wa.UsedRange.Offset(2).ClearContents
    Q = wa.Cells(1, 1).Resize(UBound(P, 1), UBound(P, 2) + 1)
        With CreateObject("Scripting.Dictionary")
            For r = 4 To UBound(P, 1)
    ID = P(r, 1) & "|" & P(r, 3) & "|" & P(r, 6) & "|" & P(r, 8)
            P(r, 9) = P(r, 7) * P(r, 9)
            If ID <> "" Then
        If .Exists(ID) Then
    k = .Item(ID): Q(k, 7) = Q(k, 7) + P(r, 7): Q(k, 9) = Q(k, 9) + P(r, 9)
        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, 9) = Q(r, 9) / Q(r, 7): Next r
        wa.Cells(3, 1).Resize(UBound(Q, 1), UBound(Q, 2)) = Q
        End With
End Sub