فرز الملفات بانشاء لكل قسم فولدر ونقل الملفات لكل قسم خاص بها 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