Aggregate Rows of Data if Condition is met (if 2 Columns contains dup values)

Hi guys,

I am trying to get a macro to run that will aggregate Rows of data based on if 2 columns contain the same value. I know the best way is to use Pivot Tables, but I absolutely can't use a pivot table, this data needs to be aggregated no pivot table as other macros will import it somewhere. Fyi real spreadsheet has 1000's of rows so can't do manually.

I have attached a spreadsheet for your reference.

Basically, the conditions to aggregate the data is:

If Column I & Column W are the same values as another Rows Column I & W, I would like to aggregate those rows to one line, while doing so summing K (the only value that changes among the Rows).

The output should give this result in 3 lines under the headers. (aggregating John's order and Abe's order)

Customer Booked {...} all other data is the same copy paste
JOHN1234 2 {...}
ALAIN1234 5 {...}
ABE1234 6 {...}

Would really appreciate any help I can get, been at this for a couple days. Everything I can find directs me to Pivot tables but I can't do it that way. Thank you!

Hi popcorn7

JOHN1234 2 {...}
ALAIN1234 5 {...}
ABE1234 6 {...}

This seems incorrect...The red part ...Rows 4 to 7 have same values in F & W
Or must it be I & W

Perhaps this...
Results as follows...
JOHN1234 2
ALAIN1234 4
ABE1234 8

Option Explicit

Sub popcorn7()
Dim val, i As Long, sr As Long, lr As Long, numrows As Long
Application.ScreenUpdating = False
With Sheet1
    With .Cells(1).CurrentRegion
        .Range(.Cells(2, 9), .Cells(.Count, 9)).AdvancedFilter xlFilterCopy, , .Range("AH1"), True
    End With
    With .Range("AH1").CurrentRegion:  val = .Value:  .Clear:  End With
    For i = 2 To UBound(val)
        With .Cells(1).CurrentRegion
            .AutoFilter 9, val(i, 1)
            sr = .Range("F2", .Range("F" & Rows.Count).End(xlUp)).SpecialCells(12).Row
            .AutoFilter 23, .Range("W" & sr)
        End With
        numrows = .AutoFilter.Range.Columns(1).SpecialCells(12).Cells.Count - 1
        If numrows > 1 Then
            lr = .Range("F" & Rows.Count).End(xlUp).Row
            .Range("K" & sr) = Application.Subtotal(9, Range("K:K"))
            .Range("K" & sr + 1 & ":K" & lr).EntireRow.Delete
        End If
        .AutoFilterMode = False
    Next i
End With
Application.ScreenUpdating = True
End Sub

Only if it works with your actual dataset...
Thanks.gif

can you kindly help me out

Sure I can ... if I had a file to work with...

Code works fine...

With Sheets("Database")

See result after code ran in upload...

Edit...slight change to code...

Option Explicit

Sub popcorn7()
Dim val, i As Long, sr As Long, lr As Long, numrows As Long, ws As Worksheet
Application.ScreenUpdating = False
Set ws = Sheets("Database")
With ws
    With .Cells(1).CurrentRegion: .Range(.Cells(2, 9), .Cells(.Count, 9)).AdvancedFilter xlFilterCopy, , .Range("AH1"), True: End With
    With .Range("AH1").CurrentRegion:  val = .Value:  .Clear:  End With
    For i = 2 To UBound(val)
        With .Cells(1).CurrentRegion
            .AutoFilter 9, val(i, 1)
            sr = ws.Range("F2", ws.Range("F" & Rows.Count).End(xlUp)).SpecialCells(12).Row
            .AutoFilter 23, ws.Range("W" & sr)
        End With
        numrows = .AutoFilter.Range.Columns(1).SpecialCells(12).Cells.Count - 1
        If numrows > 1 Then
            lr = .Range("F" & Rows.Count).End(xlUp).Row
            .Range("K" & sr) = Application.Subtotal(9, Range("K:K"))
            .Range("K" & sr + 1 & ":K" & lr).EntireRow.Delete
        End If
        .AutoFilterMode = False
    Next i
End With
Application.ScreenUpdating = True
End Sub

Hi sintek, I haven't answered you because I have been working on this on my actual data set for a day now and I am still having issues applying it. Your method of doing this is really great, I would like to go by it.

Your code bugs out because when we filter by Client like ALAIN1234, there is in reality many different Order ID's for him, not just one Order ID to aggregate. So I am looking to aggregate each of his orders. I would really appreciate it if you had a look again with this Sample Spreadsheet attached. As it stands it could only be a little edit. I am reaching out to you on last effort, as I said I been at it for a day now and can't get it, my VBA skills aren't your level.

Little Recap what I am trying to do...Basically I am trying to filter by Col I "Client", and again for Col W, aggregating Col K for each Order ID that is the same.

Really appreciate your time

Upload has no ALAIN1234

A bit more complex than we both anticipated lol....Try this...

Option Explicit

Sub popcorn7()
Dim val, val1, ws As Worksheet
Dim i As Long, ii As Long, sr As Long, lr As Long, numrows As Long, lrow As Long
Application.ScreenUpdating = False
Set ws = Sheets("Daily Input")
With ws
    lrow = .Cells(Rows.Count, "W").End(xlUp).Row
    Range("A2:AD" & lrow).Sort key1:=Range("I2:I" & lrow), order1:=xlAscending, Header:=xlNo
    With .Cells(1).CurrentRegion: .Range(.Cells(2, 9), .Cells(.Count, 9)).AdvancedFilter xlFilterCopy, , .Range("AH1"), True: End With
    With .Range("AH1").CurrentRegion:  val = .Value:  .Clear:  End With
    For i = 2 To UBound(val)
        .Cells(1).CurrentRegion.AutoFilter 9, val(i, 1)
        sr = .Range("I2", ws.Range("I" & Rows.Count).End(xlUp)).SpecialCells(12).Row
        lr = .Range("I" & Rows.Count).End(xlUp).Row
        With .Cells(1).CurrentRegion: .Range(.Cells(sr, 23), .Cells(lr, 23)).SpecialCells(12).AdvancedFilter xlFilterCopy, , .Range("AJ1"), True: End With
        With .Range("AJ1").CurrentRegion:  val1 = .Value:  .Clear:  End With
        .Cells(1).CurrentRegion.AutoFilter 9, val(i, 1)
        For ii = 2 To UBound(val1)
            .Cells(1).CurrentRegion.AutoFilter 23, val1(ii, 1)
            numrows = .AutoFilter.Range.Columns(23).SpecialCells(12).Cells.Count - 1
            If numrows > 1 Then
                sr = .Range("I2", ws.Range("I" & Rows.Count).End(xlUp)).SpecialCells(12).Row
                lr = .Range("I" & Rows.Count).End(xlUp).Row
                .Range("K" & sr) = Application.Subtotal(9, Range("K:K"))
                .Range("K" & sr + 1 & ":K" & lr).EntireRow.Delete
            End If
            .Cells(1).CurrentRegion.AutoFilter 23
        Next ii
    Next i
    .AutoFilterMode = False
End With
Application.ScreenUpdating = True
End Sub

Hi Sintek,

View my private msg regarding the updates. We are so close. :O Having an issue when there is a Client with 1 order only. Updated Sample Sheet, problem occurs with TROUBLE1234

Is it finally PERFECT...

Caught me just in time...Away for 2 weeks...

Option Explicit

Sub popcorn7()
Dim val, val1, ws As Worksheet
Dim i As Long, ii As Long, sr As Long, lr As Long, numrows As Long, lrow As Long
Application.ScreenUpdating = False
Set ws = Sheets("Daily Input")
With ws
    lrow = .Cells(Rows.Count, "W").End(xlUp).Row
    Range("A2:AD" & lrow).Sort key1:=Range("I2:I" & lrow), order1:=xlAscending, Header:=xlNo
    With .Cells(1).CurrentRegion: .Range(.Cells(2, 9), .Cells(.Count, 9)).AdvancedFilter xlFilterCopy, , .Range("AH1"), True: End With
    With .Range("AH1").CurrentRegion:  val = .Value:  .Clear:  End With
    For i = 2 To UBound(val)
        .Cells(1).CurrentRegion.AutoFilter 9, val(i, 1)
        numrows = .AutoFilter.Range.Columns(23).SpecialCells(12).Cells.Count - 1
        sr = .Range("I2", ws.Range("I" & Rows.Count).End(xlUp)).SpecialCells(12).Row
        lr = .Range("I" & Rows.Count).End(xlUp).Row
        If numrows > 1 Then
            With .Cells(1).CurrentRegion: .Range(.Cells(sr, 23), .Cells(lr, 23)).SpecialCells(12).AdvancedFilter xlFilterCopy, , .Range("AJ1"), True: End With
            With .Range("AJ1").CurrentRegion:  val1 = .Value:  .Clear:  End With
        End If
        For ii = 2 To UBound(val1)
            .Cells(1).CurrentRegion.AutoFilter 23, val1(ii, 1)
            numrows = .AutoFilter.Range.Columns(23).SpecialCells(12).Cells.Count - 1
            If numrows > 1 Then
                sr = .Range("I2", ws.Range("I" & Rows.Count).End(xlUp)).SpecialCells(12).Row
                lr = .Range("I" & Rows.Count).End(xlUp).Row
                .Range("K" & sr) = Application.Subtotal(9, Range("K:K"))
                .Range("K" & sr + 1 & ":K" & lr).EntireRow.Delete
            End If
            .Cells(1).CurrentRegion.AutoFilter 23
        Next ii
    Next i
    .AutoFilterMode = False
End With
Application.ScreenUpdating = True
End Sub