ترتيب الطلاب بحسب درجاتهم

[Muner]

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

ترتيب الطلاب.xls

[mn20]

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

الملف المرفق لعل به طلبكم.

ترتيب الطلاب.xls

[Muner]

جزاك الله اخي الفاضل(mn20) وجعله الله في ميزان حسناتك، وغفر الله لك ولنا كل ذنب .

وعفوا لو أثقلت عليك، ممكن ايضا تضيف خانة بعد المجموع الاخير يكون فيها ترتيب الطلاب كتابة حسب علاماتهم يعني ( الاول ،الثاني ،الثالث، الثالث مكرر، الرابع ...) وهكذا .

[ابراهيم الحداد]

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

ترتيب الطلاب من الاول حتى العاشر على اساس  الدرجات فى العمود    T

Sub ReRank()
Dim ws As Worksheet, Arr()
Dim LR As Long, y As Integer, TP()
Dim j As Long, p As Long, m As Long, Trb As String
Dim i As Long, x As Double, k As Double
Set ws = Sheets("ورقة البيانات")
LR = ws.Range("C" & Rows.Count).End(3).Row
Range("U8:U" & LR).Value = ""
ReDim Arr(1 To LR, 1 To 1)
j = 8
Do While j <= LR
y = WorksheetFunction.CountIf(ws.Range(ws.Cells(8, "T"), _
ws.Cells(j, "T")), ws.Cells(j, "T"))
If y = 1 Then
i = i + 1
Arr(i, 1) = ws.Cells(j, "T")
End If
j = j + 1
Loop
x = WorksheetFunction.Large(Arr, 10)
ReDim TP(1 To i, 1 To 1)
For r = 1 To i
If Arr(r, 1) >= x Then
p = p + 1
TP(p, 1) = Arr(r, 1)
End If
Next
m = 8
Do While m <= LR
For n = 1 To 10
k = WorksheetFunction.Large(TP, n)
If ws.Cells(m, "T") = k Then
Trb = Choose(n, "الاول", "الثانى", "الثالث", "الرابع", "الخامس", _
"السادس", "السابع", "الثامن", "التاسع", "العاشر")
If WorksheetFunction.CountIf(ws.Range("T8:T" & m), _
ws.Range("T" & m)) > 1 Then
Trb = Trb & " " & "مكرر"
ws.Cells(m, "U") = Trb
Else
Trb = Trb
ws.Cells(m, "U") = Trb
End If
End If
Next
m = m + 1
Loop
End Sub

 

تم تعديل فبراير 19, 2023 بواسطه ابراهيم الحداد

[mn20]

ابشر .. تم

 

ترتيب الطلاب.xls

[Muner]

شكرا جزيلا أستاذي إبراهيم الحداد، وكذلك أستاذي mn20 وكل أستاذتي في في هذا المنتدى الرائع

كنت اريد الترتيب كما هو موضح في الملف المرفق يتم الترتيب لكل طلاب الصف من الاول حتى الخمسين طالب مع احتساب كلمة مكرر للطالب المكرر ثم الترتيب الذي بعده وهكذا .

مع خالص شكري وتقديري .

ترتيب الطلاب (٥).xls

[mn20]

تم ..

ترتيب الطلاب (٥).xls

[Muner]

شكرا جزيلا اخي الغالي mn20 فعلا هذا المطلوب، جعله الله في ميزان حسناتك .

لكن في ملاحظة كما قلت لك ان الطالب عندما يكون مكررا مثلا الثاني مكرر فالطالب الذي بعده يكون ترتيبه  الثالث وليس الرابع ، وإذا كان الخامس مكرر ولو لثلاثة طلاب ترتيبهم الخامس يكون ترتيب الطالب الذي بعدهم السادس وليس السابع او الثامن وهكذا .

ارجو ان تكون الفكرة وضحت .

جزاك الله خيرا 

[ابراهيم الحداد]

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

اولا : ضع الكود التالى فى موديول مستقل و خصص له زر

Sub NewTopTen()
Dim ws As Worksheet, LR As Long
Dim Arr(), Tmp(), n As Integer, Rnk As String
Dim i As Integer, j As Integer, p As Integer
Dim Num As Integer, y As Integer
Const Rep As String = "مكرر"
Dim WF As WorksheetFunction, C As Range
Set ws = Sheets("ورقة البيانات")
Set WF = WorksheetFunction
LR = ws.Range("C" & Rows.Count).End(3).Row
ReDim Preserve Arr(1 To LR, 1 To 1)
For Each C In ws.Range("U8:U" & LR)
y = WF.CountIf(ws.Range(ws.Cells(8, "U"), _
ws.Cells(C.Row, "U")), ws.Cells(C.Row, "U"))
If y = 1 Then
p = p + 1
Arr(p, 1) = C.Value
End If
Next
If p < 50 Then
n = p - 1
Else
n = 50
End If
For i = 1 To n
Num = WF.Large(Arr, i)
For Each C In ws.Range("U8:U" & LR)
If C.Value = Num Then
Rnk = TextNums(i)
C.Offset(0, 1) = Rnk
x = WF.CountIf(ws.Range(ws.Cells(8, "U"), _
ws.Cells(C.Row, "U")), ws.Cells(C.Row, "U"))
If x > 1 Then
Rnk = TextNums(i) & " " & Rep
C.Offset(0, 1) = Rnk
End If
End If
Next
Next

End Sub

ثانيا : اما هذه الدالة المخصصة ضعها ايضا فى موديول اخر و لا تتعامل معها مرة اخرى حتى يعمل معك الكود الاول بكفاءة

Function TextNums(Num As Integer) As String
Dim Ar, Tp, Reslt As String
Dim m As Integer
Ar = Array("الاول", "الثانى", "الثالث", "الرابع", "الخامس", "السادس", "السابع", _
"الثامن", "التاسع", "العاشر", "الحادى عشر", "الثانى عشر", "الثالث عشر", _
"الرابع عشر", "الخامس عشر", "السادس عشر", "السلبع عشر", "الثامن عشر", _
"التاسع عشر", "العشرين", "الحادى و العشرين", "الثانى و العشرين", _
"الثالث و العشرين", "الرابع و العشرين", "الخامس و العشرين", "السادس و العشرين", _
"السابع و العشرين", "الثامن و العشرين", "التاسع و العشرين", "الثلاثين", "الحادى و الثلاثين", _
"الثانى و الثلاثين", "الثالث و الثلاثين", "الرابع و الثلاثين", "الخامس و الثلاثين", _
"السادس و الثلاثين", "السابع و الثلاثين", "الثامن و الثلاثين", "التاسع ة الثلاثين", _
"الاربعين", "الحادى و الاربعين", "الثانى و الاربعين", "الثالث و الاربعين", "الرابع و الاربعين", _
"الخامس و الاربعين", "السادس و الاربعين", "السابع و الاربعين", "الثامن و الاربعين", _
"التاسع و الاربعين", "الخمسين")
Tp = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, _
21, 22, 23, 24, 35, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, _
41, 42, 43, 44, 45, 46, 47, 48, 49, 50)
For m = LBound(Ar) To UBound(Ar)
If Num = m + 1 Then
Reslt = Replace(Num, Num, Ar(m))
End If
Next
TextNums = Reslt
End Function

 

[Muner]

شكرا جزيلا أستاذي الفاضل إبراهيم الحداد،

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

علما بان الترتيب أريده كما هو مثلا: (١٠٠ الاول )ثم (٩٠الثاني )،(٩٠الثاني مكرر )(٨٠ الثالث) ،(٧٠ الرابع ),(٧٠ الرابع مكرر ) وهكذا.

ترتيب الطلاب (10) (1).xls

 

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

[mn20]

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

بعد اذن استاذي ابراهيم الحداد  ارفق لكم محاولتي . مع خالص تحياتي.

ترتيب الطلاب (10) (1).xls

[Muner]

جزاك الله خيرا أخي الغالي (mn20) وشكرا لك على سرعة الرد ، حفظك الله ورعاك.

لدي ملاحظة عندما طبقته على (٦٢) طالبا حصل اختلال في الترتيب.

الرجاء اصلاحه جزاكم الله خيرا.

مع خالص شكري وتقديري 

ترتيب الطلاب(العاشر).xls

[mn20]

ابشر .. تم 

ترتيب الطلاب(العاشر).xls

[Muner]

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