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

[حسين شاكر]

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

 

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

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

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

1-  عدم ترك صف خالى فى كشف الدور الثانى

 

        2 -  ان تكون مساحة الصفحة  تحمل 14 اسم فقط

 

        3 - اضافة كود لترحيل الراسبين ايضا

 

الكود يقوم بترحيل اعمدة معينة من الشيت الى كشوف ناجح ودور ثان وراسب وهوmodule 41 

 

 

نسخة من 11 (version 2).rar

[بن علية حاجي]

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

 

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

 

أخوك بن علية

 

الملف المرفق :  نسخة من 11 (version 3).rar

[حسين شاكر]

الاستاذ الفاضل بن علية

 

     اكرمك الله الكود ضيط 100 % ولكن هناك طلب بسيط فى كشف ناجح اريد ان تنقل خانة رقم الجلوس الكود يقوم بنقل مسلسل الطالبة وليس رقم الجلوس

 

 

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

 

 

   اكرمك الله اخى فى الله اتاذى بن علية

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

السلام عليكم

قم اولا بيغيير شيت كشف ناجع كالتالي

العمود a ترقيم

العمود b الاسم

العمود c  رقم الجلوس

و نفس الشيئ بالنسبة لشيت  :  كشف الدور الثاني

ثم انسخ الكود التالي بدلا من الكود السابق :

Sub KH_START1()

Dim R As Integer, M As Integer, N As Integer
Sheets("كشف ناجح").Range("B7:Es1000").ClearContents
    Sheets("كشف الدور الثاني").Range("B7:Es1000").ClearContents
    M = 6: N = 6: S = 6
    Application.ScreenUpdating = False
         For R = 10 To 750
              If Cells(R, 74) = "ناجح" Then
                 M = M + 1
                 Range("A" & R).Range("a1:c1,d1,m1,q1,u1,z1,ad1,ag1,aj1,bm1,ap1,as1,av1,ay1,bb1,bi1,bj1,bp1,bt1,bv1").Copy
                 With Sheets("كشف ناجح")
                      .Range("A" & M).PasteSpecial xlPasteValues
                      .Range("A" & M).PasteSpecial xlPasteFormats
                      .Range("A" & M) = M - 6
                  End With
                   Application.CutCopyMode = False
                ElseIf Cells(R, 74) = "دور ثان" Then
                   N = N + 1
                 Range("A" & R).Range("a1:c1,d1,m1,q1,u1,z1,ad1,ag1,aj1,bm1,ap1,as1,av1,ay1,bb1,bi1,bj1,bp1,bt1,bv1").Copy
                   With Sheets("كشف الدور الثاني")
                        .Range("a" & N).PasteSpecial xlPasteValues
                        .Range("a" & N).PasteSpecial xlPasteFormats
                        .Range("a" & N) = (N - 6)
                   End With
                   Application.CutCopyMode = False
                ElseIf Cells(R, 74) = "راسبة" Then
                   S = S + 1
                 Range("A" & R).Range("a1:c1,d1,m1,q1,u1,z1,ad1,ag1,aj1,bm1,ap1,as1,av1,ay1,bb1,bi1,bj1,bp1,bt1,bv1").Copy
                   With Sheets("كشف راسبة")
                        .Range("A" & S).PasteSpecial xlPasteValues
                        .Range("A" & S).PasteSpecial xlPasteFormats
                        .Range("A" & S) = (S - 6)
                   End With
                   Application.CutCopyMode = False
           End If
    Next
    MsgBox "تم ترحيل   " & M - 6 & "   طالب ناجح" & Chr(10) & Chr(10) & _
    "تم ترحيل   " & (N - 6) & "   طالب دور ثاني" & Chr(10) & Chr(10) & _
    "تم ترحيل   " & (S - 6) & "   طالب راسب", vbMsgBoxRight, "الحمدلله"
    Application.ScreenUpdating = True

End Sub

تم تعديل يوليو 4, 2013 بواسطه أبو حنين

[حسين شاكر]

الاستاذ  ابو حنين

 

                اكرمك الله الكود رائع 100%    كل عام وانتم بخير وجعلة فى ميزان حسناتكم

 

    الف شكر لاخى فى الله الاستاذ بن علية على تعاونة وجعلة فى ميزان حسناتكم امين