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

**أبو حنــــين** · أغسطس 18, 2013

السلام عليكم

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

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

**قنديل الصياد** · أغسطس 18, 2013

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

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

وشاكر جدا لك

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

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

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

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

**الـعيدروس** · أغسطس 18, 2013

السلام عليكم

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

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

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

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

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

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

تم تعديل أغسطس 18, 2013 بواسطه عباد

**قنديل الصياد** · أغسطس 19, 2013

السلام عليكم

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

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

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

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

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

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

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

شكرا لك

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

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

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

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

فشكرا لجهدكم

**قنديل الصياد** · أغسطس 19, 2013

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

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

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

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

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

مع العلم بان

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

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

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

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

**الـعيدروس** · أغسطس 19, 2013

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

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

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

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

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

**قنديل الصياد** · أغسطس 19, 2013

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

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

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

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

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

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

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

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

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

**الـعيدروس** · أغسطس 19, 2013

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

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

و

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

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

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

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

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

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

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

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

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

**قنديل الصياد** · أغسطس 19, 2013

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

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

و

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

**الـعيدروس** · أغسطس 19, 2013

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

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

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

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

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

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

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

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

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

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

**قنديل الصياد** · أغسطس 19, 2013

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

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

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

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

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

**الـعيدروس** · أغسطس 19, 2013

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

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

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

تم تعديل أغسطس 19, 2013 بواسطه عباد

**قنديل الصياد** · أغسطس 20, 2013

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

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

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

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

**الـعيدروس** · أغسطس 21, 2013

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

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

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

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

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

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

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

**قنديل الصياد** · أغسطس 21, 2013

شكرا اخى الحبيب

بارك الله فيك وعليك

تم ضبط المعادلة وتم الترحيل بنجاح

khopho · نوفمبر 30, 2017

On 8/18/2013 at 4:45 PM, قنديل الصياد said:

Range("a14:ca1000").ClearContents

تسجيل الدخول

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

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

أبو حنــــين

قنديل الصياد

الـعيدروس

قنديل الصياد

قنديل الصياد

الـعيدروس

قنديل الصياد

الـعيدروس

قنديل الصياد

الـعيدروس

قنديل الصياد

الـعيدروس

قنديل الصياد

الـعيدروس

قنديل الصياد

khopho

Join the conversation

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

تصفح الموقع

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

Support

Important Information