Create a summary list

[Av8tordude]

Can anyone help me with a VBA code that will take this list and create a summary list in column W-Y. Each item should have a subtotal like in the example in the next table. The Ticker and Name are in column A & B and the Amounts are in column P. The output should be place in in C.

Greatly appreciate i anyone could offer your assistance. Thank you kindly.

Ticker

Name

Amount

<tbody>
</tbody>

BA	The Boeing Company	$(617.90)
AAPL	Apple Inc.	$(118.67)
AAPL	Apple Inc.	$ 131.34
AAPL	Apple Inc.	$(238.07)
BA	The Boeing Company	$(374.06)
BA	The Boeing Company	$(101.09)
BA	The Boeing Company	$ 36.92
SPY	SPDR S&P 500 ETF	$ 304.10
AAPL	Apple Inc.	$(538.29)
SPY	SPDR S&P 500 ETF	$ 274.10
SQ	Square	$ 466.71
AAPL	Apple Inc.	$ 87.77
IBM	International Business Machines Corporation	$ 262.10
NVDA	NVIDIA Corporation	$ 708.93
SPY	SPDR S&P 500 ETF	$ 286.69
BA	The Boeing Company	$ 933.90

<tbody>
</tbody>

icker

Name

Total

<tbody>
</tbody>

AAPL	Apple Inc.	$($657.92)
BA	The Boeing Company	$(122.23)
IBM	International Business Machines Corporation	$262.10
NVDA	NVIDIA Corporation	$708.93
SPY	SPDR S&P 500 ETF	$(864.89)
SQ	Square	$466.71

<tbody>
</tbody>

 

[Michael M]

A little confusing you say create the Summary list in Cols "W:Y"
Then you say

The output should be place in in C.

 

[Av8tordude]

Sorry about the confusion....Not sure why that happen. The output should be in column W-Y

A little confusing you say create the Summary list in Cols "W:Y"
Then you say

 

[Michael M]

Ok, is the data sorted ?

 

[Av8tordude]

No the data is not sorted

Ok, is the data sorted ?

 

[Michael M]

This if the data is not sorted !!

Sub MM1()
Dim lr As Long, r As Long
lr = Cells(Rows.Count, "a").End(xlUp).Row
Range("A2:B" & lr & ",P2:P" & lr).Copy Range("W2")
    Range("X2").Select
    ActiveWorkbook.Worksheets("Sheet2").Sort.SortFields.Add Key:=Range("X1"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Sheet2").Sort
        .SetRange Range("W2:Y" & lr)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
For r = lr To 2 Step -1
    If Cells(r, 24).Value = Cells(r - 1, 24).Value Then
        Cells(r - 1, 25).Value = Cells(r, 25).Value + Cells(r - 1, 25).Value
        Range(Cells(r, 23), Cells(r, 25)).Delete
    End If
Next r
End Sub

 

[Av8tordude]

I tried the code however, it does not take filter out unique names and total each unique name as in my example

 

[Michael M]

Hmm, works fine for me...is the sheet in question the activesheet ?
In the code the active sheet is "Sheet2", you may need to change that to suit whatever sheetname you are using

ActiveWorkbook.Worksheets([color=red]"Sheet2"[/color]).Sort.SortFields.Add Key:=Range("X1"), _

 

[Av8tordude]

I tried the code, but the math is not correct for the first row output. It shows 617.90, when it suppose to be 657.92. The rest looks like it achieves the task.

 

[Michael M]

Apple ince being the first compnay on the list, should be $-675.92, which agrees with col P AND col Y

Sub MM1()
Dim lr As Long, r As Long
lr = Cells(Rows.Count, "A").End(xlUp).Row
Range("A2:B" & lr & ",P2:P" & lr).Copy Range("W2")
    Range("X2").Select
    ActiveWorkbook.ActiveSheet.Sort.SortFields.Add Key:=Range("X2"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.activesheet.Sort
        .SetRange Range("W2:Y" & lr)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
For r = lr To 2 Step -1
    If Cells(r, 24).Value = Cells(r - 1, 24).Value Then
        Cells(r - 1, 25).Value = Cells(r, 25).Value + Cells(r - 1, 25).Value
        Range(Cells(r, 23), Cells(r, 25)).Delete
    End If
Next r
End Sub