Macro to obtain subtotal of unique combinason

Hi,

Again I would need some help to try and facilitate a very lengthy task.

Attached is a my data. From column A to D.

I need to get the subtotal for the column C (Total) and D (Qty) for all unique combination of columns A and B. Moreover, I would need it in the format given from column G.

Note that:
1. This is only a very small sample. I can have up to around 20 different Ref in column A.
2. The type under each Ref (after running the macro) should be in ascending order.
3. Only existing type under each Ref should be included.

Well, I started doing the filter option but its too lengthy. I have also tried the subtotal option but again my data is too long. Please help.

Try this macro

Sub Test()

ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Columns("A:A") _
    , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Columns("B:B") _
    , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Sheet1").Sort
    .SetRange Range("A:D")
    .Header = xlYes
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With

Columns("A:A").Copy Destination:=Columns("K:K")
Columns("K:K").RemoveDuplicates Columns:=1, Header:=xlYes
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Columns("K:K") _
    , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Sheet1").Sort
    .SetRange Columns("K:K")
    .Header = xlYes
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With

For N = 2 To Cells(Rows.Count, 11).End(xlUp).Row
    Cells(Rows.Count, 13).End(xlUp).Offset(2, 0) = Cells(N, 11)
    For M = 2 To Cells(Rows.Count, 1).End(xlUp).Row
        If Cells(M, 1) = Cells(N, 11) Then
            If Cells(M, 2) <> Cells(M - 1, 2) Or Cells(M, 1) <> Cells(M - 1, 1) Then
                Cells(Rows.Count, 13).End(xlUp).Offset(1, 0) = Cells(M, 2)
                Cells(Rows.Count, 13).End(xlUp).Offset(0, 1) = WorksheetFunction.SumIfs(Columns(3), Columns(1), Cells(Rows.Count, 13).End(xlUp).End(xlUp), Columns(2), Cells(Rows.Count, 13).End(xlUp))
                Cells(Rows.Count, 13).End(xlUp).Offset(0, 2) = WorksheetFunction.SumIfs(Columns(4), Columns(1), Cells(Rows.Count, 13).End(xlUp).End(xlUp), Columns(2), Cells(Rows.Count, 13).End(xlUp))
            End If
        End If
    Next M
Next N

End Sub

Open up the VBA editor by hitting ALT F11

Insert a new module by hitting Insert - Module

Paste the macro into the empty sheet

Hit ALT F11 to get back to the worksheet.

Run the macro by going to tools-macro in Excel 2003 or the view ribbon in Excel 2007/2010.

Dear mrice,

I apologize for the late reply but I was on holidays for a week. Kindly note that I am still unable to run it. Both your macros work just fine on Excel 2007 but bugs when it comes to Excel 2003 (which most users have here!).

I had a look at your macro - and I believe that it would be the sumifs function (which is not possible in MS 2003). It also seems that MS Excel 2003 does not run the "SortOn:=xlSortOnValues" function.

Kindly help.

msls09

Dear OllieB and mrice,

I apologize for the late reply but I was on holidays for a week. Kindly note that I am still unable to run it. Both your macros work just fine on Excel 2007 but bugs when it comes to Excel 2003 (which most users have here!).

I had a look at mrice's macro - and I believe that it would be the sumifs function (which is not possible in MS 2003). As for OllieB, it seems that MS Excel 2003 does not run the "SortOn:=xlSortOnValues" function.

Kindly help.

msls09

Hi msls09,
try it

Sub ertert()
Dim x, y(), i&, j&, k&, s$
With Range("A1:D" & Cells(Rows.Count, 1).End(xlUp).Row)
    .Sort Key1:=.Cells(1, 1), Order1:=xlAscending, _
          Key2:=.Cells(1, 2), Order2:=xlAscending, _
          Header:=xlYes
    x = .Value
End With
ReDim y(1 To UBound(x), 1 To 3)
With CreateObject("Scripting.Dictionary")
    .CompareMode = 1
    For i = 2 To UBound(x)
        If x(i, 1) <> x(i - 1, 1) Then j = j + 2: y(j, 1) = x(i, 1)
        s = x(i, 1) & "~" & x(i, 2)
        If .Exists(s) Then
            k = .Item(s)
            y(k, 2) = y(k, 2) + x(i, 3)
            y(k, 3) = y(k, 3) + x(i, 4)
        Else
            j = j + 1: .Item(s) = j
            y(j, 1) = x(i, 2)
            y(j, 2) = x(i, 3)
            y(j, 3) = x(i, 4)
        End If
    Next i
End With: y(2, 2) = "Total": y(2, 3) = "Qty"
With Range("G1:I" & Cells(Rows.Count, 7).End(xlUp).Row)
    .ClearContents: .Resize(j).Value = y()
End With
End Sub