الوارد اولا صادر اولا (first in first out (FIFO

بسم الله الرحمن الرحيم

نظرا لاهتمام بعض الاخوة بموضوع الوارد اولا صادر اولا (FIFO) 

قمنا بعمل مثال بالاكواد  

لحل هذه المشكلة 

المثال يعتمد على اعمدة مساعدة ويتم مسح البيانات منها بعد الانتهاء 

 الكود المستخدم داخل المثال  

 Sub YasserFIFO()  
   Dim z As Byte  
   'Yasserelaraby86@gmail.com  
   '+201097192367  
   Application.ScreenUpdating = False  
   Range("K6:K23").ClearContents  
   Range("D6:E23").Copy Range("R1")  
   Range("r1:s18").SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp  
   Range("G6:G23").Copy Range("T1")  
   z = 1  
   For Each x In Range("g6:g23")  
     If x.Value <> "" Then  
       If x.Value <= Cells(z, 18) Then  
         Cells(x.Row, 11) = Cells(z, 19) * x.Value  
         Cells(z, 18) = Cells(z, 18) - x.Value  
       ElseIf x.Value > Cells(z, 18) Then  
 3        Cells(x.Row, 11) = Cells(x.Row, 11) + (Cells(z, 18) * Cells(z, 19))  
         x.Value = x.Value - Cells(z, 18)  
         Cells(z, 18) = 0  
         For z = 1 To 20  
           If Cells(z, 18) = 0 Then GoTo 1  
           If Cells(z, 18) > x.Value Then GoTo 2  
           If Cells(z, 18) < x.Value Then GoTo 3  
 1        Next z  
 2        Cells(x.Row, 11) = Cells(x.Row, 11) + (Cells(z, 19) * x.Value)  
         Cells(z, 18) = Cells(z, 18) - x.Value  
       End If  
     End If  
   Next  
   Range("T1:T18").Copy Range("G6:G23")  
   Range("R1:T18").Clear  
   Range("a1").Activate  
   Application.ScreenUpdating = True  
 End Sub  

لتحميل الملف اضغط هنا

اعداد / ياسر العربي

شارك المقال

شاركه على فيسبوكشاركه على جوجل+