فرز الملفات بانشاء لكل قسم فولدر ونقل الملفات لكل قسم خاص بها VBA

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

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

  الخاص بهذه الصورة وفي المثال المرفق لدينا مثلا ثلاثة اقسام قسم الرياضة وقسم السينما وقسم التكنولوجيا

 المطلوب هو فصل الصور كل صورة حسب القسم الخاص بها مستندا على ذلك من الشيت

 هذه صورة البيانات بالشيت

وهذه صورة للملفات الموجودة داخل المجلد مع ملف الاكسيل

وهذه الصورة بعد تنفيذ الكود وانشاء فولدرات لكل قسم ونقل الصور لكل قسم خاص بها

وهذا  هو الكود المستخدم داخل الملف

 Sub Yasser()  
   Dim FLDR As Object  
   Dim LR As Long  
   Dim fldrname As String  
   Dim fldrpath As String  
   On Error Resume Next  
   LR = Cells(Rows.Count, 2).End(xlUp).Row  
   For X = 2 To LR  
     Set FLDR = CreateObject("scripting.filesystemobject")  
     fldrname = Range("B" & X).Text & "\"  
     fldrname2 = Range("A" & X).Text & ".BMP"  
     fldrpath = ThisWorkbook.Path & "\" & fldrname  
     If Not FLDR.folderexists(fldrpath) Then  
       FLDR.createfolder (fldrpath)  
     End If  
     FLDR.MoveFile Source:=ThisWorkbook.Path & "\" & fldrname2, Destination:=fldrpath  
   Next  
   MsgBox "تم معالجة البيانات"  
 End Sub  

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


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

الوارد اولا صادر اولا (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  

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

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