كود استدعاء البيانات حسب مامطلوب في ترحيل الناجحون او الراسبون او المكملون وحسب الصف

[عامر ياسر]

السلام عليكم ورحمة الله وبركاته الشرح موجود داخل ملف الاكسيل

الترحيل.xlsm

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

جرب هذا الملف (تم تعيير بعض الاشياء لحسن عمل الماكرو)

الكود

Option Explicit

Sub filter_ME()
With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
End With
Dim lr%, k%, m%: m = 5
Dim S_sh As Worksheet: Set S_sh = Sheets("الدرجات")
Dim T_sh As Worksheet: Set T_sh = Sheets("salim")
Dim My_Table As Range: Set My_Table = _
 S_sh.Range("A4").CurrentRegion
 T_sh.Range("a4").CurrentRegion.Offset(3).ClearContents
  With My_Table
    .AutoFilter
    .AutoFilter Field:=16, Criteria1:=T_sh.Range("d3")
    .AutoFilter Field:=17, Criteria1:=T_sh.Range("d2")
    Sheets("Sapace").Cells.Clear
    .Columns(18).SpecialCells(xlCellTypeVisible).Offset(1).Copy _
    Destination:=Sheets("Sapace").Range("a1")
    .Columns(2).SpecialCells(xlCellTypeVisible).Offset(1).Copy _
    Destination:=Sheets("Sapace").Range("b1")
    .Columns(3).SpecialCells(xlCellTypeVisible).Offset(1).Copy _
    Destination:=Sheets("Sapace").Range("c1")
    .Columns(5).SpecialCells(xlCellTypeVisible).Offset(1).Copy _
    Destination:=Sheets("Sapace").Range("d1")
    .AutoFilter
End With
'======================
lr = Sheets("Sapace").Cells(Rows.Count, 1).End(3).Row
 For k = 1 To lr Step 2
    T_sh.Range("b" & m).Resize(, 4).Value = _
    Sheets("Sapace").Range("a" & k).Resize(, 4).Value
    T_sh.Range("g" & m).Resize(, 4).Value = _
    Sheets("Sapace").Range("a" & k + 1).Resize(, 4).Value
    T_sh.Range("a" & m) = k: T_sh.Range("f" & m) = k + 1
    m = m + 1
    If IsEmpty(T_sh.Range("G" & m - 1)) Then T_sh.Range("f" & m - 1) = vbNullString
 Next
     With Application
    .ScreenUpdating = True
    .Calculation = xlCalculationAutomatic
End With
End Sub

الملف مرفق

 

الترحيل salim.xlsm

[عامر ياسر]

5 دقائق مضت, سليم حاصبيا said:

جرب هذا الملف (تم تعيير بعض الاشياء لحسن عمل الماكرو)

الكود

Option Explicit

Sub filter_ME()
With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
End With
Dim lr%, k%, m%: m = 5
Dim S_sh As Worksheet: Set S_sh = Sheets("الدرجات")
Dim T_sh As Worksheet: Set T_sh = Sheets("salim")
Dim My_Table As Range: Set My_Table = _
 S_sh.Range("A4").CurrentRegion
 T_sh.Range("a4").CurrentRegion.Offset(3).ClearContents
  With My_Table
    .AutoFilter
    .AutoFilter Field:=16, Criteria1:=T_sh.Range("d3")
    .AutoFilter Field:=17, Criteria1:=T_sh.Range("d2")
    Sheets("Sapace").Cells.Clear
    .Columns(18).SpecialCells(xlCellTypeVisible).Offset(1).Copy _
    Destination:=Sheets("Sapace").Range("a1")
    .Columns(2).SpecialCells(xlCellTypeVisible).Offset(1).Copy _
    Destination:=Sheets("Sapace").Range("b1")
    .Columns(3).SpecialCells(xlCellTypeVisible).Offset(1).Copy _
    Destination:=Sheets("Sapace").Range("c1")
    .Columns(5).SpecialCells(xlCellTypeVisible).Offset(1).Copy _
    Destination:=Sheets("Sapace").Range("d1")
    .AutoFilter
End With
'======================
lr = Sheets("Sapace").Cells(Rows.Count, 1).End(3).Row
 For k = 1 To lr Step 2
    T_sh.Range("b" & m).Resize(, 4).Value = _
    Sheets("Sapace").Range("a" & k).Resize(, 4).Value
    T_sh.Range("g" & m).Resize(, 4).Value = _
    Sheets("Sapace").Range("a" & k + 1).Resize(, 4).Value
    T_sh.Range("a" & m) = k: T_sh.Range("f" & m) = k + 1
    m = m + 1
    If IsEmpty(T_sh.Range("G" & m - 1)) Then T_sh.Range("f" & m - 1) = vbNullString
 Next
     With Application
    .ScreenUpdating = True
    .Calculation = xlCalculationAutomatic
End With
End Sub

الملف مرفق

 

الترحيل salim.xlsm

انت مبدع بمعنى الكلمة إجابة وعمل غاية في الروعة شكرا من القلب لك استاذي سليم حاصبيا ... لقد اختصرت لي الطريق في عملي الإداري انت غي غاية الكرم واعظم ما تقدمه هو العلم  (إن الله يحب إذا عمل أحدكم عملاً أن يتقنه ) اتقنت في الإجابة وهذا ما اريده بالضبط شكرا لك 

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

يجب كتابة هذه الكلمات (ناجح / راسب/مكمل) في الجدول الاساسي بالضبط كما هي في القائمة المنسدلة دون مسافات ناقصة او زائدة

ربما هناك بعض الاخطاء في كتابة بعضها

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

تم معالحة الامر

الكود الجديد

Option Explicit
Sub filter_ME_Please()
With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
End With
Dim My_arr(): ReDim My_arr(1 To 4)
My_arr(1) = 18: My_arr(2) = 2
My_arr(3) = 3: My_arr(4) = 5
Dim lr%, k%, m%: m = 5
Dim S_sh As Worksheet: Set S_sh = Sheets("الدرجات")
Dim T_sh As Worksheet: Set T_sh = Sheets("salim")
Dim My_Table As Range: Set My_Table = _
 S_sh.Range("A4").CurrentRegion
 T_sh.Range("a4").CurrentRegion.Offset(3).ClearContents
  With My_Table
    .AutoFilter
    .AutoFilter Field:=16, Criteria1:=T_sh.Range("d3")
    .AutoFilter Field:=17, Criteria1:=T_sh.Range("d2")
    Sheets("Sapace").Cells.Clear
    For k = 1 To 4
    .Columns(My_arr(k)).SpecialCells(xlCellTypeVisible).Copy _
    Destination:=Sheets("Sapace").Range("a1").Offset(, k - 1)
    Next

    .AutoFilter
End With
'======================
lr = Sheets("Sapace").Cells(Rows.Count, 1).End(3).Row
 For k = 2 To lr Step 2
    T_sh.Range("b" & m).Resize(, 4).Value = _
    Sheets("Sapace").Range("a" & k).Resize(, 4).Value
    T_sh.Range("g" & m).Resize(, 4).Value = _
    Sheets("Sapace").Range("a" & k + 1).Resize(, 4).Value
    T_sh.Range("a" & m) = k - 1: T_sh.Range("f" & m) = k
    m = m + 1
    
 Next
 If IsEmpty(T_sh.Range("G" & m - 1)) Then T_sh.Range("f" & m - 1) = vbNullString
     With Application
      .ScreenUpdating = True
      .Calculation = xlCalculationAutomatic
     End With
Erase My_arr
End Sub

الملف مرفق

 

 

الترحيل salim_modifier .xlsm

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

1 دقيقه مضت, عامر ياسر said:

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

ط§ظ„طھط±ط­ظٹظ„ salim.xlsm

تم ارسال الملف والكود الجديد  في المشاركة ما قبل هذه تحت اسم           الترحيل salim_modifier.xlsm 

[عامر ياسر]

فقط مشكلة بسيطة وهي فقط حينما اختار المكمل والراسب التسلسل 1 والتسلسل 2 يكرر ... جزاك الله خيرا قمت بتقليل البيانات في الجدول الأساسي والمثال صف الاول قمت بتلوينه حينما اختار المكمل للصف الاول يكرر فقط التسلسل الاول والثاني بنفس الاسم ويعطيني زيادة واحدة  حول عدد التلاميذ  المكمل الصف الاول واحد يكرره لي مرتين كما في الملف المرفق

2„ salim_modifier.xlsm

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

لاحظت انا هذا الشيء و قد ورد خظأ بسيط تم تصليحة

اعد تحميل الملف مرة احرى

الحطأ في هذا السطر (رقم 11 من الاسفل)

Sheets("Sapace").Range("a" & k ).Resize(, 4).Value

و يجب ان يكون هكذا

Sheets("Sapace").Range("a" & k + 1).Resize(, 4).Value

 

[عامر ياسر]

تمام استاذنا الكريم سليم حاصبيا ابدعت وارجو المعذرة قد اتعبتك كثيرا بأسئلتي ادعوا من الله عز وجل ان يوفقك ويزيد من علمك