How to select the results of Subtotal and copy to another work sheet?

Question

 

Dear all,

 

I have data like this( Name and Value are not the fixed name and value ):

      Name         Value

      aaa            1000

      bbb            2000

      ccc            3000

      ccc            4000

      bbb            5000

      bbb            6000

      aaa            7000

      aaa            8000

      aaa            9000

 

and I have to calculate the subtotal for each name then copy to another worksheet

like this

       Name     Value

        aaa        25000

        bbb        13000

        ccc         7000

 

How can I implement this?

I have tried the subtotal funtion but using subtotal there is no unique identify I can select and get its subtotal value to copy.

Is there any possible solutoin???

 

Many thanks

Answer 1

Test the code below, please.

 

Code Snippet

Sub getSubTotal()
Dim sRng As Range
Dim dRng As Range
Dim strFor As String
Dim PT As Range
    'activate destination sheet
    Worksheets("Sheet2").Activate
    'clear the sheet
    ActiveSheet.Cells.ClearContents
    'set the source range
    Set sRng = Worksheets("Sheet1").Range("a1").CurrentRegion.Columns(1)
    'get the unique items
    sRng.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("a1"), Unique:=True
    '2th title
    Range("b1") = sRng.Cells(1).Offset(0, 1)
    'source data area
    Set sRng = sRng.Offset(1, 0).Resize(sRng.Rows.Count - 1, 1)
    'destination data area
    Set dRng = Range([a2], [a2].End(xlDown))
    'sum the subtotal usesing arrayformula to each item
    For Each PT In dRng
        strFor = "=sum((" & sRng.Worksheet.Name & "!" & sRng.Address(0, 0) & "=" & _
                        PT.Address(0, 0) & ") * " & sRng.Worksheet.Name & "!" & sRng.Offset(0, 1).Address(0, 0) & ")"
        PT.Offset(0, 1).Value = Application.Evaluate(strFor)
    Next
End Sub