Group data by two column with a sum on the third column

[LittleFry]

I have this data set which needs to be grouped by data in the first two columns, but also with a sum within each grouping.

The attached file has a before and after.

[HSV]

Run the code and lookat sheets(2).

Sub hsv()
Dim chrtr, i As Long, cl As Range, sn As String
Application.ScreenUpdating = False
With Sheets(1)
  chrtr = Array("A", "B", "C", "D")
 
 With Sheets(2)
   .UsedRange.ClearContents
   .Range("A1").Resize(, 4) = chrtr
 End With
For i = 0 To 3

With .Range("A1:C" & .Cells(Rows.Count, 1).End(xlUp).Row)
    .AutoFilter 1, chrtr(i)
  For Each cl In Sheets(1).AutoFilter.Range.Offset(1).Columns(2).SpecialCells(12)
   If InStr(1, sn, cl, vbTextCompare) = 0 Then
     sn = sn & cl
Sheets(2).Cells(Rows.Count, Columns(i + 1).Column).End(xlUp).Offset(1) = cl & " (" & WorksheetFunction.CountIf(.Columns(2).SpecialCells(2), cl) & ")"
     End If
    Next cl
  .AutoFilter
      End With
     sn = ""
   Next i
 End With
End Sub

[event21]

Hi -

Also try;

Sub test()
Dim rng, i
rng = Range("a1").CurrentRegion
With CreateObject("scripting.dictionary")
    For x = LBound(rng) + 1 To UBound(rng)
        If Not .exists(rng(x, 1)) Then
            .Add rng(x, 1), rng(x, 1)
        End If
    Next
    i = .items
    .RemoveAll
    For x = LBound(rng) + 1 To UBound(rng)
        If Not .exists(rng(x, 1) & "[]" & rng(x, 2)) Then
            .Add rng(x, 1) & "[]" & rng(x, 2), rng(x, 3)
        Else
            .Item(rng(x, 1) & "[]" & rng(x, 2)) = .Item(rng(x, 1) & "[]" & rng(x, 2)) + rng(x, 3)
        End If
    Next
    col = 7: rw = 2
    For Each rec In i
        For Each d In .keys
            If Left(d, InStr(d, "[]") - 1) = rec Then
                Cells(rw, col) = Mid(d, InStr(d, "[]") + 2) & " (" & .Item(d) & ")"
                tot = tot + .Item(d)
            rw = rw + 1
            End If
        Next
    Cells(1, col) = rec
    Cells(rw, col) = "Total " & tot
    col = col + 1: rw = 2: tot = 0
    Next
End With
Erase rng
End Sub

Regards,
Event

[jindon]

try

Option Explicit

Sub test()
    Dim a, i As Long, dic As Object
    Dim e, s, n As Long, myTotal As Double
    Set dic = CreateObject("Scripting.Dictionary")
    dic.CompareMode = 1
    With Range("a1").CurrentRegion
        a = .Value
        For i = 2 To UBound(a, 1)
            If Not dic.exists(a(i, 1)) Then
                Set dic(a(i, 1)) = _
                CreateObject("Scripting.Dictionary")
                dic(a(i, 1)).CompareMode = 1
            End If
            dic(a(i, 1))(a(i, 2)) = dic(a(i, 1))(a(i, 2)) + a(i, 3)
        Next
        With .Offset(, .Columns.Count + 3)
            .CurrentRegion.ClearContents
            .Cells(1).Resize(, dic.Count).Value = dic.keys
            For Each e In dic
                For Each s In dic(e)
                    myTotal = myTotal + Val(dic(e)(s))
                    dic(e)(s) = s & " (" & dic(e)(s) & ")"
                Next
                n = n + 1
                .Cells(2, n).Resize(dic(e).Count).Value = _
                Application.Transpose(dic(e).items)
                .Cells(dic(e).Count + 2, n).Value = "Total " & myTotal
                myTotal = 0
            Next
            With .CurrentRegion.Columns
                .AutoFit
                .HorizontalAlignment = xlCenter
            End With
        End With
    End With
End Sub

[event21]

Hi Jindon -

Nice approach

much faster by 1.5 seconds running a test of 500000 records compared to mine.

Regards,
Event

[LittleFry]

Thank you to all...the solutions are great.