# How can this be improved? an annoying FIFO problem

#### dalian

##### New Member
Hello,

Can anyone help me improve the following? .. I have data that looks like this –

Quantity Purchased ------ Quantity Sold
50,000 -------------------- 40,000
25,000 -------------------- 20,000
150,000 ------------------- 25,000
45,000 --------------------- 100,000
80,000 --------------------- 20,000
20,000
10,000

These amounts are entered sequentially in a worksheet that functions like a database. As a rule, an item cannot be sold before it has been purchased, which means that the total number of items purchased is at least equal to the number of items sold.

What I am trying to do is write a macro that will compare how much of the item was sold to how much was purchased and give me the difference on a first-in-first-out basis, so that if the amount purchased is greater than the amount sold, then the amount sold should come from the first block of purchases. In a second run, this should work in the same way until the first block is empty. If something remains in the amount sold that has not been deducted from inventory, it should be removed from the second block of purchases, then from the next etc. At the end, I should get the following :

Result
0
0
20,000
45,000
80,000
20,000
10,000

The sum of “Result” + “Quantity Sold” should equal “Quantity Purchased”.

I started with the following and can more or less isolate the data but where I get really stuck is in the middle (after “Redim”). My guess is for this to work properly I should check whether the quantity in QuantP(i) = 0, if no, deduct QuantS(i) from it until QuantP(i) = 0, then check if something remains, if yes move on to the next QuantP, but if I put “QuantP(i + 1)” in the macro, I’ll get “subscript out of range”, so basically my problem is how do I translate all the above into VBA??

Many thanks to anyone who can help!

Sub Test ()

Sheets("Products").Activate
Range("MyRange").Select

Dim QuantP()
Dim QuantS()
Dim Result()

CountRows = Selection.CurrentRegion.Rows.Count + 1

CountP = 1
CountS = 1

For i = 1 To CountRows
If Range("c" & i).Value = "Item A" And Range("B" &i).Value = "Purchased" Then
ReDim Preserve QuantP(CountP)
QuantP(CountP) = Range("K" & i).Value
CountP = CountP + 1
End If
Next i

For j = 1 To CountRows
If Range("c" & j).Value = "Item A” And Range("B" & j).Value = "Sold" Then
ReDim Preserve QuantS(CountS)
QuantS(CountS) = Range("K" & j).Value
CountS = CountS + 1
End If
Next j

ReDim Resultat(1 To CountP)

For i = 1 To UBound(QuantP)
If i <= UBound(QuantS) Then
If QuantP(i) > QuantS(i) Then
Result(i) = QuantP(i) - QuantS(i)
QuantP(i) = Result(i)

ElseIf QuantP(i) < QuantS(i) Then
Result(i) = ?????
End If
End If
Next i

Sheets("sheet2").Activate

For k = 1 to UBound(Result)
Cells(k + 1, 1).Value = Result(k)
next k

End Sub

### Excel Facts

How can you turn a range sideways?
Copy the range. Select a blank cell. Right-click, Paste Special, then choose Transpose.

#### jindon

##### MrExcel MVP
Code:
``````Private Sub Worksheet_Change(ByVal Target As Range)
Dim a(), i As Long, x As Double
If Intersect(Target, Range("a:b")) Is Nothing Then Exit Sub
With Application
With .WorksheetFunction
x = .Sum(Range("a:a")) - Range("b:b"))
End With
If (Not IsNumeric(Target.Value)) + (x < 0) + (Target.Count > 1) Then
MsgBox "Invalid entry/selection"
.EnableEvents = False
.Undo
.EnableEvents = True
Exit Sub
End If
End With
a = Range("a1").CurrentRegion.Resize(,2).Value
ReDim Preserve a(1 To UBound(a,1), 1 To 3)
For i = 2 To UBound(a,1)
If IsEmpty(a(i,2)) Then a(i,2) = 0
If x > 0 Then
If a(i,2) >= x Then
a(i,3) = a(i,2) - x : x = 0
Else
a(i,3) = 0 : x = x - a(i,3)
End If
Else
a(i,3) = a(i,2)
End If
Next
Application.EnableEvents = False
Range("a1").CurrentRegion.Resize(,3).Value = a
Application.EnableEvents = True
End Sub``````

#### dalian

##### New Member
Hi Jindon,

Thanks for your help but I still have problems : what I need is a macro that will compute inventory in a(i,2) until a(i,3) is empty, and if that is not the case, subtract from it until it is but I don't know how to express that in Vba! #### jindon

##### MrExcel MVP
Hi Jindon,

Thanks for your help but I still have problems : what I need is a macro that will compute inventory in a(i,2) until a(i,3) is empty, and if that is not the case, subtract from it until it is but I don't know how to express that in Vba! a(i,3) is an inventry of the purchase of that line, so at the beggining everything is empty at the start. Don't understand what you mean.

Is there any possiblity to have empty cell(s) in the data area of col.B?
I mean something like
Col.B
1000
500
Empty
200
Empty
300

#### dalian

##### New Member
No, column B cannot have empty or zero values, but I can't seem to make this work !

#### jindon

##### MrExcel MVP
Code:
``````Private Sub Worksheet_Change(ByVal Target As Range)
Dim a(), i As Long, x As Double, y As Double
If Intersect(Target, Range("a:b")) Is Nothing Then Exit Sub
With Application
With .WorksheetFunction
y = .Sum(Range(b:b))
x = .Sum(Range("a:a")) - Range("b:b"))
End With
If (Not IsNumeric(Target.Value)) + (x < 0) + (Target.Count > 1) Then
MsgBox "Invalid entry/selection"
.EnableEvents = False
.Undo
.EnableEvents = True
Exit Sub
End If
End With
a = Range("a1").CurrentRegion.Resize(,2).Value
ReDim Preserve a(1 To UBound(a,1), 1 To 3)
For i = 2 To UBound(a,1)
If IsEmpty(a(i,2)) Then a(i,2) = 0
If y > 0 Then
If a(i,2) >= y Then
a(i,3) = a(i,2) - y : y = 0
Else
a(i,3) = 0 : y = y - a(i,3)
End If
Else
a(i,3) = a(i,2)
End If
Next
Application.EnableEvents = False
Range("a1").CurrentRegion.Resize(,3).Value = a
Application.EnableEvents = True
End Sub``````

Replies
5
Views
726
L
Replies
6
Views
409
Legacy 487876
L
Replies
0
Views
264
Replies
8
Views
353
Replies
15
Views
560

### Forum statistics

1,191,576
Messages
5,987,390
Members
440,095
Latest member
yanaungmyint ### We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.

### Which adblocker are you using?    1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option. Go back

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com". Go back

### Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button. Go back

### Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button. Go back