问从变量中减去值，直到该变量为0 Excel VBA

EN

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

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

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

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

=SUMPRODUCT(([Ticker]=[@Ticker])*([Bucket]=[@Bucket])*([LS]="Long")*([Lots]))-SUMPRODUCT(([Ticker]=[@Ticker])*([Bucket]=[@Bucket])*([LS]="Short")*([Lots]))