طريقة ترتيب الطلاب رقميا وكتابيا دون القفز في حال وجود مكرر

[Salem2020]

برنامج المدرسة.xlsm

طريقة ترتيب الطلاب رقميا وكتابيا دون القفز في حال وجود مكرر

السادة الاكارم اهل الاختصاص

أتمنى مساعدتي في حل هذه المشكلة العويصة

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

ستجد ثلاث ورقات ما يهمنا هي ورقة الشهادة حيث أرغب بعمل ترتيب للطلاب في الخانة الصفراء في الشهادة بحيث لا يقفز على المراتب في حال كان هناك تكرار في الترتيب (الترتيب طبعا يعتمد على خانة المجموع العام في ورقة المسودة) حيث سيتم استيراد البيانات من هناك.

فمثلا لو كان هناك 4 طلاب مشتركون في مرتبة (الأول) أرغب بأن يبدأ بعد ذلك بوضع المرتبة (الثاني) بدلا من (الخامس) وهكذا

جربت أكثر من دالة وأكثر من طريقة ولكن للأسف عندما أنجح في عمل الترقيم الرقمي تخطئ دالة الترتيب حيث تكتب أمام الرقم (6) الخامس وأحيانا يعطي Error

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

أتمنى أن تكون قد وصلت الفكرة

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

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

بما انك لم ترسل ملف للعمل عليه

اليك هذا الملف ربما يفيدك

الطلبة الاوائل.xlsm

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

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

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

ارجو توضيح الرقم السرى لمحرر الاكواد

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

 

 

 

[Salem2020]

جزاك الله خير أخي ابراهيم 

هذا هو رقم محرر الاكواد 

3061979

ولك جزيل الشكر 

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

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

الكود الاتى يحسب الترتيب حتى العشرة الاوائل

Sub AllRanks()
Dim ws As Worksheet, j As Long
Dim Arr As Variant, k As Double
Dim LR As Long, i As Long
Dim m As Integer, n As Integer, x As Integer
Set ws = Sheets("مسودة الدرجات")
LR = ws.Range("R" & Rows.Count).End(3).Row
Dim TP()
ReDim Arr(1 To LR, 1 To 1)
j = 9
Do While j <= LR
y = WorksheetFunction.CountIf(ws.Range(ws.Cells(9, "R"), ws.Cells(j, "R")), ws.Cells(j, "R"))
If y = 1 Then
i = i + 1
Arr(i, 1) = ws.Cells(j, "R")
End If
j = j + 1
Loop
If i <= 10 Then
x = WorksheetFunction.Large(Arr, i)
End If
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 = 9
Do While m <= LR
For n = 1 To i
k = WorksheetFunction.Large(TP, n)
If ws.Cells(m, "R") = k Then
yy = Choose(n, "الاول", "الثانى", "الثالث", "الرابع", "الخامس", _
"السادس", "السابع", "الثامن", "التاسع", "العاشر")
If ws.Range("R" & m) <> Empty Then
If WorksheetFunction.CountIf(ws.Range("R9:R" & m), ws.Range("R" & m)) > 1 Then
yy = yy & " " & "مكرر"
ws.Cells(m, "U") = yy
Else
yy = yy
ws.Cells(m, "U") = yy
End If
End If
End If
Next
m = m + 1
Loop
End Sub

 

[Salem2020]

أحسنت .. بارك الله جهدك ونفع بك .. وجعله في ميزان حسناتك

تم حل المشكلة بنجاح بفضل مجهود حضرتك وكودك الممتاز 👍