How to select the results of Subtotal and copy to another work sheet?
- 0
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
Answers
- 0
Test the code below, please.
Code SnippetSub 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
