فَهرَست بأسَمَاء تلاميذ المدرَسَه

[عامر ياسر]

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

الشرح داخل ملف الاكسيل

aamir.xlsm

[سليم حاصبيا]

ريما نال الاعجاب

الكود

Option Explicit

Sub Salim_Index()
Application.ScreenUpdating = False
Dim S_sh As Worksheet: Set S_sh = Sheets("بيانات التلاميذ")
Dim Index_sh As Worksheet: Set Index_sh = Sheets("فَهرَست")
Dim Targ_sh As Worksheet: Set Targ_sh = Sheets("Sapace")
Dim my_st1$, my_st2$
Dim lr%: lr = S_sh.Cells(Rows.Count, 1).End(3).Row
Dim New_Lr%
Dim Flt_Rg As Range: Set Flt_Rg = S_sh.Range("a15:k" & lr)
Dim k%, m%: m = 6
Index_sh.Range("a6:F150").ClearContents
Targ_sh.Cells.Clear
my_st1 = "=" & UCase(Index_sh.[g5] & "*") & ""
    Flt_Rg.AutoFilter Field:=5, Criteria1:=my_st1
    
     Flt_Rg.Columns(3).SpecialCells(xlCellTypeVisible).Copy
     Targ_sh.Range("a5").PasteSpecial Paste:=xlPasteValues
    
    Flt_Rg.Columns(5).SpecialCells(xlCellTypeVisible).Copy
     Targ_sh.Range("b5").PasteSpecial Paste:=xlPasteValues
     Application.CutCopyMode = False
    Flt_Rg.AutoFilter

   New_Lr% = Targ_sh.Cells(Rows.Count, 1).End(3).Row
   For k = 6 To New_Lr% Step 2
     
    Index_sh.Cells(m, 2) = Targ_sh.Cells(k, 1): Index_sh.Cells(m, 1) = k - 5
    Index_sh.Cells(m, 3) = Targ_sh.Cells(k, 2)
    Index_sh.Cells(m, 5) = Targ_sh.Cells(k + 1, 1): Index_sh.Cells(m, 4) = k - 4
    Index_sh.Cells(m, 6) = Targ_sh.Cells(k + 1, 2)
    m = m + 1
    Next
   Application.ScreenUpdating = True
End Sub

 

Salim_Index.xlsm

[عامر ياسر]

الأستاذ والاخ الحبيب سليم حاصبيا

جزاك الله خيرا عمل رائع جعله الله في ميزان حسناتكم

وفقك الله وزادكم من فضله علما وشرفا

تقبل وافر احترامي وتقديري ... قد نال الاعجاب والثناء على اجاباتك التي تدل على علمكَ الرصين وكرمك في العطاء . شكرا والف شكر على دقة الإجابة ... 

عذراً لتأخري في الرد النت ضعيف