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

Fri, 25 Jul 2008 04:06:58 Z

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

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

Fri, 25 Jul 2008 08:34:12 Z

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