اذهب الي المحتوي
أوفيسنا

تعديل فى ترحيل الناجحين والراسبين

قنديل الصياد

بواسطه قنديل الصياد
في منتدى الاكسيل Excel

 مشاركة

الردود الموصى بها

أبو حنــــين

أبو حنــــين

قام بنشر
قام بنشر

السلام عليكم

جرب الكود التالي

Sub tarheel()

'gr1
Dim LR As Integer
LR = [a10000].End(xlUp).Row
Sheets("ناجحون صف اول اخر العام").Range("a14:ca1000").ClearContents
Sheets("راسبون صف اول اخر العام").Range("a14:ca1000").ClearContents
Application.ScreenUpdating = False
With Sheets("رصد اول اخر العام")
 x = 14: y = 14:
For i = 14 To LR
    If .Cells(i, 77) = "ناجح" And .Cells(i, 2) <> "" Then
        .Range("F" & i).Resize(1, 74).Copy
Sheets("ناجحون صف اول اخر العام").Range("D" & x).PasteSpecial xlPasteValues
Sheets("ناجحون صف اول اخر العام").Range("A" & x) = x - 13
Sheets("ناجحون صف اول اخر العام").Range("b" & x) = .Range("b" & x)
Sheets("ناجحون صف اول اخر العام").Range("C" & x) = .Range("C" & x)
x = x + 1
 ElseIf (.Cells(i, 77) = "راسب" Or .Cells(i, 77) = "غ" Or .Cells(i, 77) = "له دور ثانى") And .Cells(i, 2) <> "" Then
        .Range("f" & i).Resize(1, 74).Copy
        Sheets("راسبون صف اول اخر العام").Range("d" & y).PasteSpecial xlPasteValues
Sheets("راسبون صف اول اخر العام").Range("A" & y) = y - 13
Sheets("راسبون صف اول اخر العام").Range("b" & y) = .Range("b" & y)
Sheets("راسبون صف اول اخر العام").Range("C" & y) = .Range("C" & y)
    y = y + 1
    End If
    
Next
Application.CutCopyMode = False
Application.ScreenUpdating = True

End With
End Sub
  • Like 1
رابط هذا التعليق
شارك
قنديل الصياد

قنديل الصياد

قام بنشر
  • الكاتب
قام بنشر

الله عليك استاذى العزيز

ساطلب منك ان تعدل على باقى الاكواد وساكتب لحضرتك عمود الشرط لباقى الصفوف

وشاكر جدا لك

وكل كلمات الشكر لا تفى بما اريد ان اقول لك استاذى الحبيب

 

عمود الشرط للصف الثانى كالصف الاول  by

عمود الشرط للصف الثالث   bp

عمود الشرط للصف الرابع والخامس والسادس   cg

رابط هذا التعليق
شارك
الـعيدروس

الـعيدروس

قام بنشر
قام بنشر (معدل)

السلام عليكم

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

 

عملت على الكود رغم ان تعديل الاستاذ ابو حنين ادى الغرض

لاكن حاولت ان اربط اكواد الصفوف كامله بكود 

الكود فعال مع الملف الذي على الرابط التالي

http://www.gulfup.com/?Yd7S3C 

لوجود اختلاف في تسميات الاوراق

وتم تعديله على الملف المرفق في الرابط

وهذا الكود النهائي

Private Const Rsb As String = "راسبون"
Private Const Na_h As String = "ناجحون"
Private Const Rs As String = "راسب"
Private Const Ng As String = "ناجح"
Private Const D_2 As String = "له دور ثانى"
Private Const D_1 As String = "له دور ثان"
Public Sub A_Tr()
Dim Sn As Worksheet
Set Sn = ActiveSheet
With Sn
'On Error Resume Next
Select Case .CodeName
       Case Is = "ورقة36": Cl = 77
       Case Is = "ورقة40": Cl = 77
       Case Is = "ورقة41": Cl = 68
       Case Is = "ورقة42": Cl = 85
       Case Is = "ورقة43": Cl = 85
       Case Is = "ورقة44": Cl = 85
End Select
En_S False
La = .Cells(.Rows.Count, 1).End(xlUp).Row
With Sheets(S_Nm(.Name, "N"))
 .Range(.Cells(14, 1), .Cells(1000, Cl + 2)).ClearContents
End With
With Sheets(S_Nm(.Name, "R"))
 .Range(.Cells(14, 1), .Cells(1000, Cl + 2)).ClearContents
End With
rr = 14: R2 = 14: Rw = 1: Rw2 = 1
For R = 14 To La
Cll = IIf(Cl = 85, 3, 6)
If .Cells(R, Cl).Value = Ng And .Cells(R, 2).Value <> "" Then
         Union(.Range(.Cells(R, 2), .Cells(R, 3)), .Range(.Cells(R, Cll), .Cells(R, Cl + 3))).Copy
        Sheets(S_Nm(.Name, "N")).Range("B" & rr).PasteSpecial xlPasteValues
        Sheets(S_Nm(.Name, "N")).Range("A" & rr) = Rw
        Application.CutCopyMode = False
        rr = rr + 1: Rw = Rw + 1
ElseIf (.Cells(R, Cl).Value = Rs Or .Cells(R, Cl).Value = "غ" Or .Cells(R, Cl).Value = D_1 Or _
.Cells(R, Cl).Value = D_2) And .Cells(R, 2) <> "" Then
         Union(.Range(.Cells(R, 2), .Cells(R, 3)), .Range(.Cells(R, Cll), .Cells(R, Cl + 3))).Copy
        Sheets(S_Nm(.Name, "R")).Range("B" & R2).PasteSpecial xlPasteValues
        Sheets(S_Nm(.Name, "R")).Range("A" & R2) = Rw2
        Application.CutCopyMode = False
        R2 = R2 + 1: Rw2 = Rw2 + 1
End If
Next
En_S True
End With
End Sub
Private Function S_Nm(N$, i$)
Dim Sh As Worksheet
Dim Sm$
a = IIf(i = "R", Rsb, Na_h)
For Each Sh In ThisWorkbook.Worksheets
 Nm = Sh.Name
 If Mid(Nm, 1, 6) = a And Mid(Nm, 10, Len(Nm)) Like "*" & Mid(N, 5, Len(N)) Then
  Sm = Sh.Name
  Exit For
End If
Next
S_Nm = Sm
End Function
Private Function En_S(B As Boolean)
 With Application
  .Calculation = IIf(B, -4105, -4135)
  .ScreenUpdating = B
  .EnableEvents = B
 End With
End Function

اربط الكود باازرار اوراق الرصد

تم تعديل بواسطه عباد
رابط هذا التعليق
شارك
قنديل الصياد

قنديل الصياد

قام بنشر
  • الكاتب
قام بنشر

السلام عليكم

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

 

عملت على الكود رغم ان تعديل الاستاذ ابو حنين ادى الغرض

لاكن حاولت ان اربط اكواد الصفوف كامله بكود 

الكود فعال مع الملف الذي على الرابط التالي

http://www.gulfup.com/?Yd7S3C 

لوجود اختلاف في تسميات الاوراق

وتم تعديله على الملف المرفق في الرابط

وهذا الكود النهائي

Private Const Rsb As String = "راسبون"
Private Const Na_h As String = "ناجحون"
Private Const Rs As String = "راسب"
Private Const Ng As String = "ناجح"
Private Const D_2 As String = "له دور ثانى"
Private Const D_1 As String = "له دور ثان"
Public Sub A_Tr()
Dim Sn As Worksheet
Set Sn = ActiveSheet
With Sn
'On Error Resume Next
Select Case .CodeName
       Case Is = "ورقة36": Cl = 77
       Case Is = "ورقة40": Cl = 77
       Case Is = "ورقة41": Cl = 68
       Case Is = "ورقة42": Cl = 85
       Case Is = "ورقة43": Cl = 85
       Case Is = "ورقة44": Cl = 85
End Select
En_S False
La = .Cells(.Rows.Count, 1).End(xlUp).Row
With Sheets(S_Nm(.Name, "N"))
 .Range(.Cells(14, 1), .Cells(1000, Cl + 2)).ClearContents
End With
With Sheets(S_Nm(.Name, "R"))
 .Range(.Cells(14, 1), .Cells(1000, Cl + 2)).ClearContents
End With
rr = 14: R2 = 14: Rw = 1: Rw2 = 1
For R = 14 To La
Cll = IIf(Cl = 85, 3, 6)
If .Cells(R, Cl).Value = Ng And .Cells(R, 2).Value <> "" Then
         Union(.Range(.Cells(R, 2), .Cells(R, 3)), .Range(.Cells(R, Cll), .Cells(R, Cl + 3))).Copy
        Sheets(S_Nm(.Name, "N")).Range("B" & rr).PasteSpecial xlPasteValues
        Sheets(S_Nm(.Name, "N")).Range("A" & rr) = Rw
        Application.CutCopyMode = False
        rr = rr + 1: Rw = Rw + 1
ElseIf (.Cells(R, Cl).Value = Rs Or .Cells(R, Cl).Value = "غ" Or .Cells(R, Cl).Value = D_1 Or _
.Cells(R, Cl).Value = D_2) And .Cells(R, 2) <> "" Then
         Union(.Range(.Cells(R, 2), .Cells(R, 3)), .Range(.Cells(R, Cll), .Cells(R, Cl + 3))).Copy
        Sheets(S_Nm(.Name, "R")).Range("B" & R2).PasteSpecial xlPasteValues
        Sheets(S_Nm(.Name, "R")).Range("A" & R2) = Rw2
        Application.CutCopyMode = False
        R2 = R2 + 1: Rw2 = Rw2 + 1
End If
Next
En_S True
End With
End Sub
Private Function S_Nm(N$, i$)
Dim Sh As Worksheet
Dim Sm$
a = IIf(i = "R", Rsb, Na_h)
For Each Sh In ThisWorkbook.Worksheets
 Nm = Sh.Name
 If Mid(Nm, 1, 6) = a And Mid(Nm, 10, Len(Nm)) Like "*" & Mid(N, 5, Len(N)) Then
  Sm = Sh.Name
  Exit For
End If
Next
S_Nm = Sm
End Function
Private Function En_S(B As Boolean)
 With Application
  .Calculation = IIf(B, -4105, -4135)
  .ScreenUpdating = B
  .EnableEvents = B
 End With
End Function

اربط الكود باازرار اوراق الرصد

اخى واستاذى العزيز

شكرا لك

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

ويعمل على باقى الصفوف  تماما

 

وايضا جربت كود اخى واستاذى / ابو جنين

ويعمل على الصف الاول والثانى تماما

فشكرا لجهدكم

رابط هذا التعليق
شارك
قنديل الصياد

قنديل الصياد

قام بنشر
  • الكاتب
قام بنشر

ولكن بعد اذن استاذى الكبير الاستاذ / عباد

افضل الاكواد لكل صف على حدة كما فعل معى استاذنا الحبيب  الاستاذ / ابو حنين

لانى افضل كل كود مستقل عن الاخر

فرجائى من استاذى ابو حنين

التعديل ايضا على اكواد الصف الثالث والرابع

مع العلم بان

عمود الشرط للصف الثالث bp

وعمود الشرط للصف الرابع والخامس والسادس cg

واشكر افضالكم وجهدكم مع اساتذتى

الاستاذ /عباد      والاستاذ / ابو حنين

رابط هذا التعليق
شارك
الـعيدروس

الـعيدروس

قام بنشر
قام بنشر

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

موجود في ورقة الناجحين والراسبين وغير موجود في الرصد

وعمود " التقدير " لكل مادة موجود في الناجحين والراسبين 

وغير موجود في الرصد 

هذا سبب ترحيل ونقص بعض اعمد مادة " التربية دينية "

رابط هذا التعليق
شارك
قنديل الصياد

قنديل الصياد

قام بنشر
  • الكاتب
قام بنشر

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

موجود في ورقة الناجحين والراسبين وغير موجود في الرصد

وعمود " التقدير " لكل مادة موجود في الناجحين والراسبين 

وغير موجود في الرصد 

هذا سبب ترحيل ونقص بعض اعمد مادة " التربية دينية "

عمود التقدير العام موجود فى كشف الرصد باسم  النتيجة العامة للطالب وحضرتك واضع عليه رقم 68

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

وموجود فى الرابط الذى قمت حضرتك بارساله كالتالى :

http://www.gulfup.com/?Yd7S3C
رابط هذا التعليق
شارك
الـعيدروس

الـعيدروس

قام بنشر
قام بنشر

اخي الحبيب قنديل الصياد

" رصد ثالث اخر العام "

و

" ناجحون صف ثالث اخر العام "

" راسبون صف ثالث اخر العام "

 

جداول المواد للصفوف  "اول"  و "ثاني" و "رابع" و "خامس" و"سادس"

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

 

اما " ثالث"  التقدير موجود للناجحين والراسبين / وفي رصد ثالث غير موجود

وبرضه عمود "التقدير العام" موجود للناجحين والراسبين / وفي رصد ثالث غير موجود

 

ارجو ان تكون وضحت لديك الصورة

والاصح تحذف الاعمدة لانها فريده غير مطبقة على الصفوف البقيه

او احاول اعدلك على الكود بحيث يتجاوز عمود " التقدير " للصف الثالث

رابط هذا التعليق
شارك
قنديل الصياد

قنديل الصياد

قام بنشر
  • الكاتب
قام بنشر

اخي الحبيب قنديل الصياد

" رصد ثالث اخر العام "

و

" ناجحون صف ثالث اخر العام "

" راسبون صف ثالث اخر العام "

 

جداول المواد للصفوف  "اول"  و "ثاني" و "رابع" و "خامس" و"سادس"

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

 

اما " ثالث"  التقدير موجود للناجحين والراسبين / وفي رصد ثالث غير موجود

وبرضه عمود "التقدير العام" موجود للناجحين والراسبين / وفي رصد ثالث غير موجود

 

ارجو ان تكون وضحت لديك الصورة

والاصح تحذف الاعمدة لانها فريده غير مطبقة على الصفوف البقيه

او احاول اعدلك على الكود بحيث يتجاوز عمود " التقدير " للصف الثالث

استاذى العزيز

الاعمدة موجودة واليك صور من الملف الذى ارسلته حضرتك

صورة من كشف رصد ثالث

XzGvn.gif

صورة من كشف الناجحين صف ثالث

k0XJI.gif

صورة من كشف الراسبون صف ثالث

HuoKF.gif

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

(النتيجة العامة للطالب )

رابط هذا التعليق
شارك
الـعيدروس

الـعيدروس

قام بنشر
قام بنشر

هذا مااقصدة يوجد عمودين في الناجحين والراسبين

عمود التقدير وعمود النتيجة

واما في الرصد غير موجود عمود التقدير

لو تلاحظ في الرصد للصفوف الاخرى موجوده كلا العمودين

هذا ماادى الى اختلال في الكود

لان المدى واحد

عموما بالامكان عمل حلقة تكرارية وتحديد الاعمدة

ولاكن سوف يبطئ الكود اكثر

لو تنسخ جدول رصد صف ثاني اخر العام

الى رصد صف ثالث وتضيف بياناته من احد النسخ التي لديك تنحل المشكلة

رابط هذا التعليق
شارك
قنديل الصياد

قنديل الصياد

قام بنشر
  • الكاتب
قام بنشر

استاذى العزيز

قمت بنسخ كشف رصد الصف الثالث

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

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

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

 

G.png

 

 

رابط هذا التعليق
شارك
الـعيدروس

الـعيدروس

قام بنشر
قام بنشر (معدل)

تفضل اخي الكريم

جرب الملف ارفقناه على الرابط التالي

 

ارجو ان يكون زبط معك

 

                                                                             

         G.png    

تم تعديل بواسطه عباد
رابط هذا التعليق
شارك
قنديل الصياد

قنديل الصياد

قام بنشر
  • الكاتب
قام بنشر

استاذى العزيز

تم الترحيل فعلا ولكن توجد مشكلة

ان بعض الطلبة ممكن لهم دور ثانى مازالوا فى ورقة الناجحون فى الصف الثالث

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

mrslH.gif

رابط هذا التعليق
شارك
الـعيدروس

الـعيدروس

قام بنشر
قام بنشر

اخي الحبيب قنديل الصياد

 

لاحظ بيانات ورقة الرصد "لصف ثالث اخر العام "

لرقم جلوس "33" و "71"  المشار اليهم

في عمود "النتيجة العامه للطالب"

في عمود "V" = "دور ثان" ولاكن مشار اليهم "النتيجة العامه للطالب" ناجح

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

ربما المشكله في المعادلة 

 

rvLAG.gif

رابط هذا التعليق
شارك
  • 4 years later...

من فضلك سجل دخول لتتمكن من التعليق

ستتمكن من اضافه تعليقات بعد التسجيل



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

  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information

  I accept