كود مميز لحساب المخزون ( FIFO , LIFO , WA )

[أبو العاصم]

السلام عليكم ورحمة الله

أثناء التنقل بين المنتديات

وقعت على كود لعملية حساب المخزون

أود من الإخوة المباركين المساعدة فى إدارج الكود فى ملف إكسيل لفهمه ومحاولة تطبيقه 

الرابط وبه صورة لشيت الاكسيل الذى طبق عليه الكود

http://www.mrexcel.com/forum/excel-questions/167756-inventory-fifo-lifo-average-cost.html

 

الكود الأول 

Private Sub Worksheet_Change(ByVal Target As Range)
With Target
If .Count > 1 Then Exit Sub
If Not IsNumeric(.Value) Then Exit Sub
If Not Intersect(.Cells(1, 1), Range("e:g")) Is Nothing And _
.Row > 6 Then FIFO
End With
End Sub

 

الكود الثانى 

Private Sub Worksheet_Change(ByVal Target As Range)
With Target
If .Count > 1 Then Exit Sub
If Not IsNumeric(.Value) Then Exit Sub
If Not Intersect(.Cells(1, 1), Range("e:g")) Is Nothing And _
.Row > 6 Then LIFO
End With
End Sub

 

الكود الثالث

Private Sub Worksheet_Change(ByVal Target As Range)
With Target
If .Count > 1 Then Exit Sub
If Not IsNumeric(.Value) Then Exit Sub
If Not Intersect(.Cells(1, 1), Range("e:g")) Is Nothing And _
.Row > 6 Then AVR_COST
End With
End Sub

 

كود المعادلات البلتى إن 

Sub FIFO()
Dim a As Variant, Cost As Double, sumIn As Double, sumOut As Double, _
i As Long, ii As Long, n As Long
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
With Sheets("FIFO")
.Range("i7", .Cells(Rows.Count, "i").End(xlUp)).ClearContents
a = .Range("e7", .Cells(Rows.Count, "g").End(xlUp)).Resize(, 5).Value
n = 1
For i = LBound(a, 1) To UBound(a, 1)
If Not IsEmpty(a(i, 3)) Then
sumOut = a(i, 3)
For ii = n To i - 1
If Not IsEmpty(a(ii, 2)) Then
sumIn = sumIn + a(ii, 2)
If sumIn > sumOut Then
Exit For
Else
Cost = Cost + a(ii, 1) * a(ii, 2)
a(ii, 2) = Empty
End If
End If
Next
If sumIn - sumOut > 0 Then
Cost = (Cost + (a(ii, 1) * (a(ii, 2) - (sumIn - sumOut)))) / sumOut
a(ii, 2) = sumIn - sumOut
Else
Cost = Cost / sumOut
End If
a(i, 5) = Cost
sumIn = 0: sumOut = 0: Cost = 0: n = ii
End If
Next
.Range("i7").Resize(UBound(a, 1)) = Application.Index(a, 0, 5)
Erase a
End With
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
End Sub


Sub LIFO()
Dim a As Variant, Cost As Double, sumIn As Double, sumOut As Double, _
i As Long, ii As Long
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
With Sheets("LIFO")
.Range("i7", .Cells(Rows.Count, "i").End(xlUp)).ClearContents
a = .Range("e7", .Cells(Rows.Count, "g").End(xlUp)).Resize(, 5).Value
For i = LBound(a, 1) To UBound(a, 1)
If Not IsEmpty(a(i, 3)) Then
sumOut = a(i, 3)
For ii = i - 1 To 1 Step -1
If Not IsEmpty(a(ii, 2)) Then
sumIn = sumIn + a(ii, 2)
If sumIn > sumOut Then
Exit For
Else
Cost = Cost + a(ii, 1) * a(ii, 2)
a(ii, 2) = Empty
End If
End If
Next
If sumIn - sumOut > 0 Then
Cost = (Cost + (a(ii, 1) * (a(ii, 2) - (sumIn - sumOut)))) / sumOut
a(ii, 2) = sumIn - sumOut
Else
Cost = Cost / sumOut
End If
a(i, 5) = Cost
sumIn = 0: sumOut = 0: Cost = 0: n = ii
End If
Next
.Range("i7").Resize(UBound(a, 1)) = Application.Index(a, , 5)
Erase a
End With
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
Erase a
End Sub

Sub AVR_COST()
Dim a, i As Long, Bal As Double, Debit As Double
Dim AVcost As Double
With Application
.Calculation = xlCalculationManual
.EnableEvents = False
End With
With Sheets("AVR COST")
a = .Range("e7", .Cells(.Rows.Count, "g").End(xlUp)).Resize(, 3).Value
.Range("i7", .Cells(.Rows.Count, "i").End(xlUp)).ClearContents
ReDim Preserve a(1 To UBound(a, 1), 1 To 4)
For i = LBound(a, 1) To UBound(a, 1)
If a(i, 2) > 0 Then
Bal = Bal + a(i, 2)
Debit = Debit + a(i, 1) * a(i, 2)
AVcost = Debit / Bal
ElseIf a(i, 3) > 0 Then
a(i, 4) = AVcost
Debit = Debit - a(i, 3) * AVcost
Bal = Bal - a(i, 3)
End If
Next
.Range("i7").Resize(UBound(a, 1)) = Application.Index(a, 0, 4)
Erase a
End With
With Application
.Calculation = xlCalculationAutomatic
.EnableEvents = True
End With
End Sub

الرجاء الإهتمام لإثراء الفكرة وتطبيقها

تم تعديل مارس 10, 2015 بواسطه Abo3asem