ترحيل الطالب المنقول الى ورقة الطلبة المنقولين نهائيا

[أبو محمد عباس]

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

الاخوة الاعزاء والاساتذة الكرام  جزاكم الله خيرا

ارجو ابداء المساعدة لغرض ترحيل الطلبة المنقولين من ورقة ( الاسماء حسب الفصول)  , ترحيلهم ومسح بياناتهم الى ورقة المنقولين من المدرسة والشرط وضعته في العمود ( U ) في ورقة ( الاسماء حسب الفصول)  وهو كلمة ( نقل) فكل طالب امام اسمه كلمة نقل ترحيل بياناته وتمسح نهائيا من ورقة (الاسماء حسب الفصول ) دون ان تمسح المعادلات الموجودة في ورقة (الاسماء حسب الفصول )علما بان الفصول تحت بعض لكن بفاصل لكل 50 طالب 

اثابكم الله وزادكم من فضله علما وخيرا كثيرا

تقبلوا فائق احترامي وتقديري

 

قوائم المدرسة.rar

 

[أبو حنــــين]

السلام عليكم

استعمل هذا الكود

Sub sCopy_To()

Application.ScreenUpdating = False
lr = Sheets("الاسماء حسب القصول").Cells(Rows.Count, "C").End(xlUp).Row + 1
x = 5
For i = 1 To lr
If Sheets("الاسماء حسب القصول").Cells(i, 21) = "نقل" Then
  Sheets("الاسماء حسب القصول").Range("B" & i).Resize(1, 9).Copy
  With Sheets("المنقولين من المدرسة")
 .Range("B" & x).PasteSpecial xlPasteValues
 .Range("A" & x) = x - 4
  End With
  x = x + 1
  End If
  Next
Application.ScreenUpdating = True
Application.CutCopyMode = False

End Sub

[أبو محمد عباس]

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

الاستاذ والاخ الحبيب ابو حنين جزاكم الله خيرا

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

وفقكم الله ورعاكم واعطاكم الصحة والعافية واغدق عليكم نعمه ظاهرة وباطنة

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

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

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

اعزكم الله واعلى مقامكم وزادكم من فضله علما وخيرا كثيرا

دمتم برعاية الله وحفظه

[عبدالله باقشير]

السلام عليكم

 

بعد اذن اخي الحبيب ابو حنين

هذا الكود اعددته مع المسح والفرز للجداول

يجب تنفيذ الكود من الورقة (الاسماء حسب القصول)

Sub kh_trheel()
Dim cel As Range
Dim Lr As Long, Lrr As Long, R As Long, i As Long, iCont As Long

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Lrr = Cells(Rows.Count, "C").End(xlUp).Row

With Sheets("المنقولين من المدرسة")
    Lr = .Cells(Rows.Count, "B").End(xlUp).Row
    iCont = WorksheetFunction.Max(.Range("A5").Resize(Lr))
    
    For R = 5 To Lrr
        If Cells(R, "U").Value = "نقل" Then
            i = i + 1
            .Cells(Lr + i, "A").Value = iCont + i
            .Cells(Lr + i, "B").Resize(1, 8).Value = Cells(R, "B").Resize(1, 8).Value
            If cel Is Nothing Then Set cel = Cells(R, "A").Resize(1, 23) Else Set cel = Union(cel, Cells(R, "A").Resize(1, 23))
        End If
    Next
End With

If i Then
    On Error Resume Next
    cel.SpecialCells(xlCellTypeConstants).ClearContents
    On Error GoTo 0
    
    For R = 5 To Lrr Step 53
        With Cells(R, "A").Resize(50, 23)
            .Sort .Columns(3), xlAscending
        End With
    Next
    
End If
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Set cel = Nothing
End Sub

تحياتي

[أبو محمد عباس]

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

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

وانعم عليكم بالصحة وتمام العافية ورزقكم خير الدنيا وخير الاخرة

اعمالكم فخر لنا وللوطن العربي زادك الله من فضله علما وخيرا كثيرا

اكرمكم الله في الدارين  واعلى مقامكم واعزكم

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

تقبلوا  فائق احترامي وتقديري

[عبدالله باقشير]

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

جزاكم الله خيرا واثابكم بدعائكم واعطاكم بمثله اضعاف مضاعفة

 

تقبلوا تحياتي وشكري