Subtracting values from a variable until that variable is 0 Excel VBA - vba

Question

I'm doing work to automate a ledger of mine based on the FIFO accounting principle (First in First out), where anything that would be referred to as a contra balance would be subtracted from the first entry, then the second, until that variable is zero (or if there is residual begin a new accounting line).
Generally what I have been doing to add a new position to this ledger (not removing any balance simply creating a line item is this...
Tickerstring = TTB 'TTB is the user defined input for the ticker
tickercolumn = HBWS.Cells.Find(What:="Ticker").Column 'Use this to identify
what column the ticker field is
Set TickerResult = HBWS.Cells.Find(What:=TickerString, LookIn:=xlValues)
If Not TickerResult Is Nothing Then
tickerRow = TickerResult.Row
Else
End If 'Identifies the row which the actual Ticker is in i.e. the TTB
HBWS.Cells(tickerRow, tickercolumn) = TTB
I use that same concept to define the amount of Shares, and whether they are long and short. Inserting Userform inputs into the respective cells.
My question is, say I run that code 3 times and now have 3 lines items that look like this
AAPL 300 Long
AAPL 100 Long
AAPL 100 Long
Then I want to add a new position for 600 short, which would go through the FIFO accounting process and remove 300 from the first row, 100 from the second, 100 from the third, then create a new line with the 100 short. How would I go about doing that?
I would imagine that I would be subtracting from a user defined variable i.e take 300 out of the first row, now my defined variable is left at 300 (when it started at 600).
Basically i think the best way to describe this would be how do I subtract from a variable based on current workbook values, then continue using this in my sub procedure.
EDIT: Editing my post for clarity
i have the following entry in my spreadsheet
I want to run my macro to take my short position indicated in the below userform subtract it from currently in my spread sheet then create a residual line representing what is left in the short position
The end state should look like this
Let me know if you need additional info

Answer 1

Requirements:
Maintain a ledger of shares transactions, generated from an user form input (one at a time).
Calculate & show the net position of the shares, using the FIFO inventory valuation method.
Proposed Solution:
The requirements can be achieved using:
A ListObject to contain the ledger of transactions and to calculate the end position after each transaction.
A PivotTable to show the end position of the shares (and any other report needed).
The figure below shows the proposed ListObject and PivotTable
ListObject Fields:
Input from user form
Ticker : Share symbol.
L/S : Share position (Long\Short).
Lots : Quantity of shares.
Calculated by VBA procedure
L/S.Net: Net share position (Long\Short).
Qty: Net share quantity (absolute value).
Lots.Net: Net share quantity.
T: Record Type (P: Prior \ R: Residual), used to flag the latest transaction of a share.
TimeStamp: Record date & time of posting, used to apply the FIFO valuation method.
VBA Procedure:
See explanations\coments inserted in the procedure.
Option Private Module
Option Compare Text
Option Explicit
Option Base 1
Rem Updated 20180504_121918
Sub ListObject_Stocks_Ledger_FIFO(vRcrd As Variant)
Dim aFlds As Variant, vFld As Variant
aFlds = [{"Ticker","L/S","Lots","T","TimeStamp","Lots.Net","L/S.Net","Qty"}]
Dim lo As ListObject, pt As PivotTable
Dim sTicker As String, lCnt As Long, lPos As Long
Dim lRow As Long, bCol As Byte, b As Byte
Dim sFml As String
Dim vValue As Variant
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Rem Set Objects
With ThisWorkbook.Worksheets("Sht(0)") 'change as required
Application.Goto .Cells(1), 1
Set pt = .PivotTables("ptPositions")
Set lo = .ListObjects("loPositions")
End With
With lo
Rem Set ListObject New Row
lRow = 1 + .ListRows.Count
Select Case lRow
Case 1
Rem ListObject with zero records
.HeaderRowRange.Cells(2, 1).Value2 = "!NEW"
Case Else
vFld = "Ticker"
sTicker = vRcrd(1)
bCol = .ListColumns(vFld).Index
lCnt = WorksheetFunction.CountIfs(.DataBodyRange.Columns(bCol), sTicker)
Rem Flag prior Ticker records
Select Case lCnt
Case 0
Rem New Ticker - NO ACTION
Case 1
Rem Ticker with only one prior record
lPos = WorksheetFunction.Match(sTicker, .DataBodyRange.Columns(bCol), 0)
.ListColumns("T").DataBodyRange.Cells(lPos).Value2 = "P"
Case Else
Rem Ticker with only one prior record
.Range.AutoFilter Field:=bCol, Criteria1:=sTicker
.ListColumns("T").DataBodyRange.SpecialCells(xlCellTypeVisible).Value2 = "P"
.Range.AutoFilter
End Select: End Select
Rem Add New Record
For Each vFld In aFlds
b = 1 + b
bCol = .ListColumns(vFld).Index
Rem Set Field Value\Formula
sFml = vbNullString
vValue = vbNullString
Select Case vFld
Case "Ticker", "L/S", "Lots": vValue = vRcrd(b)
Case "T": vValue = "R"
Case "TimeStamp": vValue = CDbl(Now)
Case "L/S.Net"
sFml = "=IF(NOT(EXACT([#T],'R')),CHAR(39)," & vbLf _
& "IF([#[Lots.Net]]<0,'Short',IF([#[Lots.Net]]>0,'Long','Zero')))"
Case "Qty"
sFml = "=IF(NOT(EXACT([#T],'R')),CHAR(39)," & vbLf _
& "ABS([#[Lots.Net]]))"
Case "Lots.Net"
sFml = "=IF(NOT(EXACT([#T],'R')),CHAR(39),SUM(" & vbLf _
& "SUMIFS([Lots],[Ticker],[#Ticker],[L/S],'Long',[TimeStamp],'<='&[#TimeStamp])," & vbLf _
& "-SUMIFS([Lots],[Ticker],[#Ticker],[L/S],'Short',[TimeStamp],'<='&[#TimeStamp])))"
End Select
Rem Apply Field Value\Formula
Select Case vbNullString
Case Is <> vValue
.DataBodyRange.Cells(lRow, bCol).Value2 = vValue
Case Is <> sFml
sFml = Replace(sFml, Chr(39), Chr(34))
With .DataBodyRange.Columns(bCol)
.Formula = sFml
.Value2 = .Value2
End With: End Select: Next: End With
Rem Sort ListObject
With lo.Sort
With .SortFields
.Clear
.Add Key:=lo.ListColumns("Ticker").DataBodyRange, _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.Add Key:=lo.ListColumns("TimeStamp").DataBodyRange, _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
End With
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Rem Refresh PivotTable
pt.PivotCache.Refresh
Application.EnableEvents = False
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = False
End Sub
Use this procedure to simulate the posting from the user form:
Sub ListObject_Stocks_Ledger_FIFO_TEST()
Dim aDATA As Variant, vRcrd As Variant
aDATA = Array( _
Array("AAPL", "Long", "300"), _
Array("AAPL", "Long", "100"), _
Array("AAPL", "Long", "100"), _
Array("AAPL", "Short", "600"), _
Array("BCS", "Long", "300"), _
Array("BCS", "Long", "100"), _
Array("BCS", "Short", "500"), _
Array("Test", "Long", "100"), _
Array("Test", "Long", "200"), _
Array("Test", "Long", "300"), _
Array("Test", "Short", "400"))
For Each vRcrd In aDATA
Call ListObject_Stocks_Ledger_FIFO(vRcrd)
: Stop
Next
End Sub

Answer 2

This could be an example of what you want to do, hopefully is usefull to you:
Sub test()
Dim reduce_amount As String
reduce_amount = Val(InputBox("Number:"))
Dim cell As Range
For Each cell In Selection
cell_value = Mid(cell.Value, 6, 3)
If IsNumeric(cell_value) Then
reduce_amount = reduce_amount - cell_value
End If
Next cell
If reduce_amount > 0 Then
Selection.End(xlDown).Offset(1, 0).Value = "AAPL " & reduce_amount & " Long"
End If
End Sub

Answer 3

I think you should make it so each transaction stands on it's own (unless you have a good reason to do it otherwise). I never store "state" in a cell if possible. What about keeping track of each bucket. Here's an example
Public Sub AddLots(ByVal Ticker As String, ByVal Lot As Double)
Dim rCell As Range
Dim LotRemains As Double
Dim dc As Scripting.Dictionary
Dim dToTake As Double
Dim ThisTicker As String, ThisLS As String, ThisLot As Double, ThisBucket As Long, ThisTotal As Double
Dim lo As ListObject
Dim aOutput() As Variant
Dim MaxBucket As Long
Dim i As Long
LotRemains = Lot
Set dc = New Scripting.Dictionary
Set lo = Sheet1.ListObjects(1)
For Each rCell In lo.ListColumns(1).DataBodyRange.Cells
'Store this row's values
ThisTicker = rCell.Value: ThisLS = rCell.Offset(0, 1).Value: ThisLot = rCell.Offset(0, 2).Value
ThisBucket = rCell.Offset(0, 3).Value: ThisTotal = rCell.Offset(0, 4).Value
'if the ticker is the same
If ThisTicker = Ticker Then
'if it's going the opposite way of our transaction
If (Lot > 0 And ThisLS = "Short") Or _
(Lot < 0 And ThisLS = "Long") Then
'if there's still something left in the bucket
If ThisTotal <> 0 Then
If Abs(ThisTotal) >= Abs(LotRemains) Then
dToTake = LotRemains
Else
dToTake = -ThisTotal
End If
'store this bucket
dc.Add ThisTicker & "|" & ThisBucket, dToTake
'reduce the amount left to test
LotRemains = LotRemains - dToTake
'stop looking if we've used it all up
If LotRemains = 0 Then Exit For
End If
End If
End If
Next rCell
'this is an array we'll write out to the worksheet
ReDim aOutput(1 To dc.Count + IIf(LotRemains <> 0, 1, 0), 1 To 4)
'for every bucket we saved, put it in the array
For i = 1 To dc.Count
aOutput(i, 1) = Ticker
aOutput(i, 2) = IIf(Lot > 0, "Long", "Short")
aOutput(i, 3) = Abs(dc.Items(i - 1))
aOutput(i, 4) = Split(dc.Keys(i - 1), "|")(1)
Next i
'if we couldn't use it all up, get the next bucket number
If LotRemains <> 0 Then
For Each rCell In lo.ListColumns(1).DataBodyRange.Cells
If rCell.Value = Ticker Then
If rCell.Offset(0, 3).Value > MaxBucket Then
MaxBucket = rCell.Offset(0, 3).Value
End If
End If
Next rCell
'then add a new bucket to the array
aOutput(dc.Count + 1, 1) = Ticker
aOutput(dc.Count + 1, 2) = IIf(Lot > 0, "Long", "Short")
aOutput(dc.Count + 1, 3) = Abs(LotRemains)
aOutput(dc.Count + 1, 4) = MaxBucket + 1
End If
'write out the new transactions to the worksheet
lo.ListRows.Add.Range.Resize(UBound(aOutput, 1), UBound(aOutput, 2)).Value = aOutput
End Sub
Start here
Then run AddLots "BCS", 400 and get
Then run AddLots "BCS", -1000 and get
Then use a pivot table to see where you are by ticker, by bucket, or whatever
The formula in the last column of the table is
=SUMPRODUCT(([Ticker]=[#Ticker])*([Bucket]=[#Bucket])*([LS]="Long")*([Lots]))-SUMPRODUCT(([Ticker]=[#Ticker])*([Bucket]=[#Bucket])*([LS]="Short")*([Lots]))

Answer 4

I looked at all of the answers posted and took a few ideas from each. I used the below code to control the variable and then I have other code that kind of compiles everything using the final variable.
The section of code that clears out the other lots though and defines the variable is below
Dim rCell As Range
Dim reduce_amount As Variant
Dim HBWS As Worksheet
Dim TickerTotalString As String
TickerTotalString = "Total " & TTB
Set HBWS = Sheets("Hedgebook")
Dim FormulaWS As Worksheet
Set FormulaWS = Sheets("Formula_Template")
LastHBR = HBWS.Cells(HBWS.Rows.Count, "B").End(xlUp).Row
ClastHBC = HBWS.Cells(3, HBWS.Columns.Count).End(xlToLeft).Column
LastFWSR = FormulaWS.Cells(FormulaWS.Rows.Count, "B").End(xlUp).Row
CLASTFWSC = FormulaWS.Cells(3, FormulaWS.Columns.Count).End(xlToLeft).Column
Tickercolumn = HBWS.Cells.Find(What:="Ticker").Column
Datecolumn = HBWS.Cells.Find(What:="Date&Time Booked").Column
LScolumn = HBWS.Cells.Find(What:="L/S").Column
Lotscolumn = HBWS.Cells.Find(What:="Lots").Column
Conversioncolumn = HBWS.Cells.Find(What:="Conversion Cents").Column
Borrowcolumn = HBWS.Cells.Find(What:="Borrow (bps)").Column
Set Tickerresult = HBWS.Cells.Find(What:=TickerTotalString, LookIn:=xlValues)
If Not Tickerresult Is Nothing Then
Tickerrow = Tickerresult.Row
Else
End If
reduce_amount = LTB 'Userform input that defines the total lots
If reduce_amount > 0 Then
For Each rCell In HBWS.Range(Cells(3, Tickercolumn), Cells(LastHBR, Tickercolumn))
If rCell.Value = TTB And rCell.Offset(0, -1).Value <> TickerTotalString And reduce_amount > 0 Then
Cell_value = rCell.Offset(0, 3).Value
If reduce_amount < Cell_value Then
rCell.Offset(0, 3).Value = Cell_value - reduce_amount
ElseIf reduce_amount > Cell_value Then
rCell.Offset(0, 3).Value = 0
reduce_amount = reduce_amount - Cell_value
ElseIf reduce_amount = Cell_value Then
reduce_amount = 0
rCell.Offset(0, 3).Value = 0
End If
End If
Next
End If