Fifo Method Of Stock Valuation

[sujittalukde]

Also posted at http://www.ozgrid.com/forum/showthread.php?t=71862 but not geeting any reply So posting here.

have a file where I want to make a report which will put the stocks having positive balances along with their prices and values.

Stocks are to be valued on FIFO (First in first out) method ie when the stocks are sold it means it were sold from the first lot bought and so on.



Reporting is required for Shares Held For eg. for Stock A, Buy qtn is (50+50+100+<sell>+100) and sell qtn is 100 So total balance is Buy Qtn 300 - sell Qtn 100 = 200 Sell Qtn 100 will out of first 50 & then next 50 (First in so first out) balance held in hand is out of last two Qtn 100 purchases. The prices are corresponding to these two lots of 100 stocks.

Reporting will be for Stock held (lotwise) See Sheet 2 of the file attached.
Basis of price will be fixed ie no formula etc and corresponding to those lots.

Actually these data are copied from web qwery so formula etc are not required. For cost purpose, price and Total correponding the balnce qtn lot are relevant

In case more clarification required, do let me know. I will try to make them clear.

FIFO.xls
	A	B	C	D	E	F	G
1	Stock	Date	Action	Qty.	Rate	Total
2	A	25-Nov-04	Buy	50	70.3	3,546.70
3	A	20-Jul-05	Buy	50	66	3,330.85
4	A	01-Sep-05	Buy	100	82	8,275.97
5	A	23-Sep-05	Sell	100	76.5	7,579.12
6	A	17-Oct-05	Buy	100	73.8	7,448.38
7	B	03-Jan-05	Buy	200	125.49	25,325.16
8	B	12-Jan-05	Sell	200	98.5	19,522.39
9	BA	05-Sep-06	Sell	300	143	42,485.23	Qtn balance is negative so ignore this stock in reporting
10	BC	21-Dec-04	Buy	20	284.7	5,745.33
11	BC	12-Jan-05	Sell	20	248.6	4,927.18
12	C	21-Dec-04	Buy	300	15.3	4,631.40	Red font means buy sell matched
13	C	12-Jan-05	Sell	300	17.7	5,262.12
14	C	17-Jan-05	Buy	200	18.35	3,703.08
15	C	03-Mar-06	Buy	97	25.55	2,508.38	yellow background means these are in balance
16	C	26-Apr-06	Buy	103	24.05	2,507.69	and should be reported
17	C	05-Dec-06	Buy	100	30.8	3,111.91
18	C	08-Mar-07	Buy	100	32.95	3,327.18
19	D	15-Jan-07	Buy	100	128.5	12,974.24
20	E	08-Mar-07	Buy	100	64.65	6,527.36
21	HH	31-May-07	Buy	100	62.5	6,310.48
22	ID	07-Dec-04	Buy	70	50.85	3,591.59
23	ID	12-Jan-05	Sell	60	68.65	4,081.87
24	IDF	30-Dec-04	Buy	10	107.25	1,100.85
25	IDF	12-Jul-05	Sell	17	112.8	1,888.13	Qtn balance is negative so ignore this stock in reporting
Sheet1

 

[veyselemre]

Sub Test()
'http://www.mrexcel.com/board2/viewtopic.php?t=280040
'jindon
Dim a, i As Long, ii As Long, iii As Long, iv As Long, w(), x, y, z, n As Long
a = Sheets("Sheet1").Range("a1").CurrentRegion.Resize(, 6).Value
With CreateObject("Scripting.Dictionary")
     .CompareMode = vbTextCompare
     For i = 2 To UBound(a, 1)
          If Not .exists(a(i, 1)) Then
               ReDim w(1 To 4, 1 To 1)
               For ii = 1 To 3: w(ii, 1) = a(i, ii + 3): Next
               w(4, 1) = a(i, 2)
               If a(i, 3) = "Sell" Then w(1, 1) = "Ignored"
               .Add a(i, 1), w
          Else
               w = .Item(a(i, 1))
               If w(1, 1) <> "Ignored" Then
                    If a(i, 3) = "Buy" Then
                         ReDim Preserve w(1 To 4, 1 To UBound(w, 2) + 1)
                         z = UBound(w, 2)
                         For ii = 1 To 3: w(ii, z) = a(i, ii + 3): Next
                         w(4, z) = a(i, 2)
                    Else
                         With Application.WorksheetFunction
                              If .Sum(.Index(w, 1, 0)) - a(i, 4) < 0 Then
                                   w(1, 1) = "Ignored": GoTo Here
                              End If
                         End With
                         For iii = 1 To UBound(w, 2)
                              If w(1, iii) >= a(i, 4) Then
                                  esk = w(1, iii)
                                  w(1, iii) = w(1, iii) - a(i, 4)
'                                  MsgBox esk & vbCr & w(1, iii) & vbCr & w(3, iii) & vbCr & w(3, iii) / esk * w(1, iii)
                                  w(3, iii) = w(3, iii) / esk * w(1, iii)
                                  If w(1, iii) = 0 Then Exit For
                              Else
                                  a(i, 4) = a(i, 4) - w(1, iii): w(1, iii) = 0
                              End If
                         Next
                    End If
               End If
Here:
               .Item(a(i, 1)) = w
          End If
     Next
     x = .keys: y = .items: Erase a
     For i = 0 To UBound(y)
          If y(i)(1, 1) = "Ignored" Then .Remove (x(i))
     Next
     x = .keys: y = .items
End With
 
With Sheets("Sheet2").Range("a3")
    .CurrentRegion.Offset(1).ClearContents
     For i = 0 To UBound(y)
          For ii = 1 To UBound(y(i), 2)
               If y(i)(1, ii) <> 0 Then
                    .Offset(n).Value = x(i)
                    .Offset(n, 1).Value = y(i)(4, ii)
                    .Offset(n, 2).Value = "Buy"
                    .Offset(n, 3).Value = y(i)(1, ii)
                    .Offset(n, 4).Value = y(i)(2, ii)
                    .Offset(n, 5).Value = y(i)(3, ii) '.Offset(n, 3).Value * .Offset(n, 4).Value
                    n = n + 1
               End If
          Next
     Next
End With
End Sub

 

[sujittalukde]

THanks you This is fully working.
Just one more thing

1. Can subtotoal function be added to the same ie the code will show the subtotal at each change in items and then bold and shade the same with back ground color?

2. At the subtotal row, average price should also come as shown in the HTML image which will be derived by dividing the Total amount by Total Qtn.

FIFO.xls
	A	B	C	D	E	F
1
2	Name of the Stock	Date		Qtn.	Price	Amount
3	A	01/09/2005	Buy	100	82	8275.97
4	A	17/10/2005	Buy	100	73.8	7448.38
5	A Total			200	78.62	15724.35
6	C	17/01/2005	Buy	200	18.35	3703.08
7	C	03/03/2006	Buy	97	25.55	2508.38
8	C	26/04/2006	Buy	103	24.05	2507.69
9	C	05/12/2006	Buy	100	30.8	3111.91
10	C	08/03/2007	Buy	100	32.95	3327.18
11	C Total			600	25.26	15158.24
12	D	15/01/2007	Buy	100	128.5	12974.24
13	D Total			100	129.74	12974.24
14	E	08/03/2007	Buy	100	64.65	6527.36
15	E Total			100	65.27	6527.36
16	HH	31/05/2007	Buy	100	62.5	6310.48
17	HH Total			100	63.10	6310.48
18	ID	07/12/2004	Buy	10	50.85	513.0843
19	ID Total			10	51.31	513.0843
Sheet2

 

[veyselemre]

Sub Formatting()
Set wf = WorksheetFunction
Sheets("Sheet2").Select
[a3:f65536].Font.Bold = False
[a3:f65536].Interior.ColorIndex = xlNone
st = 4
strt:
For x = st To Cells(Rows.Count, 1).End(3).Row + 1
    If Cells(x, 1) <> Cells(x - 1, 1) Then
        Rows(x).Insert
            With Range(Cells(x, "a"), Cells(x, "f"))
                .Interior.ColorIndex = 15
                .Font.Bold = True
            End With
            Cells(x, 1) = Cells(x, 1).Offset(-1) & " Total"
            Cells(x, 4) = wf.Sum(Range(Cells(st - 1, 4), Cells(x - 1, 4)))
            Cells(x, 6) = Round(wf.Sum(Range(Cells(st - 1, 6), Cells(x - 1, 6))), 2)
            Cells(x, 5) = Round(Cells(x, 6) / Cells(x, 4), 2)
        st = x + 2
        GoTo strt
    End If
Next x
Set wf = Nothing
End Sub

 

[jindon]

Thanks guys,
try this one

Sub Test()
Dim a, i As Long, ii As Long, iii As Long, w(), x, y, z, n As Long
a = Sheets("Sheet1").Range("a1").CurrentRegion.Resize(, 6).Value
With CreateObject("Scripting.Dictionary")
     .CompareMode = vbTextCompare
     For i = 2 To UBound(a, 1)
          If Not .exists(a(i, 1)) Then
               ReDim w(1 To 6, 1 To 1)
               For ii = 1 To 6: w(ii, 1) = a(i, ii): Next
               If a(i, 3) = "Sell" Then w(1, 1) = "Ignored"
               .Add a(i, 1), w
          Else
               w = .Item(a(i, 1))
               If w(1, 1) <> "Ignored" Then
                    If a(i, 3) = "Buy" Then
                         ReDim Preserve w(1 To 6, 1 To UBound(w, 2) + 1)
                         z = UBound(w, 2)
                         For ii = 1 To 6: w(ii, z) = a(i, ii): Next
                    Else
                         With Application.WorksheetFunction
                              If .Sum(.Index(w, 1, 0)) - a(i, 4) < 0 Then
                                   w(1, 1) = "Ignored": GoTo Here
                              End If
                         End With
                         For iii = 1 To UBound(w, 2)
                              If w(4, iii) >= a(i, 4) Then
                                  w(4, iii) = w(4, iii) - a(i, 4)
                                  w(6, iii) = _
                                       WorksheetFunction.Round(w(4, iii) * w(5, iii), 2)
                                  If w(4, iii) = 0 Then Exit For
                              Else
                                  a(i, 4) = a(i, 4) - w(4, iii): w(4, iii) = 0
                              End If
                         Next
                    End If
               End If
Here:
               .Item(a(i, 1)) = w
          End If
     Next
     x = .keys: y = .items: Erase a
     For i = 0 To UBound(y)
          If y(i)(1, 1) = "Ignored" Then .Remove (x(i))
     Next
     x = .keys: y = .items
End With
Set r = Sheets("sheet2").Range("a3")
With Sheets("Sheet2").Range("a3")
     .Resize(Rows.Count - 3).EntireRow.Clear
     myMin = 1
     For i = 0 To UBound(y)
          For ii = 1 To UBound(y(i), 2)
               If y(i)(1, ii) <> 0 Then
                    For iii = 1 To 6
                        .Offset(n, iii - 1).Value = y(i)(iii, ii)
                    Next
                    n = n + 1
                    myMax = WorksheetFunction.Max(myMax, n)
               End If
          Next
          .Offset(n).Value = x(i) & " Total"
          .Offset(n, 3).Resize(, 3).Formula = _
               Array("=subtotal(9,d" & myMin + 2 & ":d" & myMax + 2 & ")", _
                        "=round(average(e" & myMin + 2 & ":e" & myMax + 2 & "),2)", _
                        "=subtotal(9,f" & myMin + 2 & ":f" & myMax + 2 & ")")
          With .Offset(n).Resize(, 6)
               .Interior.ColorIndex = 15
               .Font.Bold = True
          End With
          myMin = myMax + 2
          n = n + 1
     Next
End With
End Sub

 

[sujittalukde]

thank guys, but I think I have to modify the codes to suit my range . WOuld someone from you please include comments with respect to where the ranges say for rows or columns I have to change or simply modify the code to cover entire sheet 1 as the data changes day by day.

 

[jindon]

thank guys, but I think I have to modify the codes to suit my range . WOuld someone from you please include comments with respect to where the ranges say for rows or columns I have to change or simply modify the code to cover entire sheet 1 as the data changes day by day.

You need to tell me exactly how the sheet laid out.

 

[sujittalukde]

Thnaks The sheet is laid out exactly in the same manner as shown in my earlier posts but data are more ie column are same but rows are more

 

[jindon]

The the code should work as it is unless you have empty row/column within the data range.

 

[sujittalukde]

yeah the code is working Sorry I was wrong Now the result is coming correct. Thanks for the effort and help that you and others have provided.