بطاقات العلامات المدرسية ترتيب تصاعدي وفق المجموع

[abou_stef]

مساء الخير وشكر مكرر للاخوة الذين لم يبخلوا علينا بالمساعدة

مستمر بالعمل على بطاقات علامات التلاميذ

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

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

أقصد اول، ثاني، ثالت ... وقد يكون هناك اول، ثاني، ثاني مكرر، رابع، خامس ...

مرفق الملف والسؤال في الصفحة الاولى

ترتيب التلاميذ تصاعديا.xlsm

[أبوعيد]

السلام عليكم

بالنسبة للترتيب أول , أول مكرر ثاني , ثاني مكرر ,......

لماذا نكتب مكرر ؟

عندما يقرأ الطالب نتيجته بأنه (أول) فقط فيحسب أنه الأول الوحيد في الصف

والمكرر عندما يقرأ نتيجته (أول مكرر) يعرف أنه يشترك في الترتيب مع شخص آخر

 

إذن (الأول) لم يعلم أن معه شخص آخر اشترك معه في الترتيب

الخلاصة :

أن الصحيح من وجهة نظري أن تكتب هكذا

أول مكرر , أول مكرر , أول مكرر , حتى يعلم كل واحد من الثلاثة أنهم يشتركون في الترتيب مع أشخاص آخرين

تقبل تحياتي

 

[عبدالله بشير عبدالله]

السلام عليكم

اوافق  استاذتا ابو عيد  على ما تفضل به

ولكن احيانا لائحة الدراسة والامتحانات تنص على هذه الطريقة

على كل حال

من اكواد وكنوز المنتدى  فيه طلبك ان شاء الله

ترتيب التلاميذ تصاعديا (1).xlsm

 

تم تعديل فبراير 7 بواسطه عبدالله بشير عبدالله

[abou_stef]

شكرا لكم اخوتي، لا يهم ان يكتب كلمة مكرر ولكن الترتيب اول ثاني ثالث او اول اول ثالث...

قمت بتنزيل الملف المرفق وسأحاول البحث عن الحل واشارككم النتيجة ان شاء الله

[عبدالله بشير عبدالله]

  يمكن الغاء مكرر من الكود

ss = " مكرر": RNK = i - 1: Exit For

استبدلها

ss = " ": RNK = i - 1: Exit For

 

تم تعديل فبراير 7 بواسطه عبدالله بشير عبدالله

[abou_stef]

شكرا لكم اخوتي وأخص يالذكر الأخ عبدالله بشير

وعندي طلب، في الملف نفسه، حضرتك كتبت كود تحفيظ الشهادات بملف PDF

تصدير الملف يحصل باسم Grade 01 بغض النظر عن اسم الملف الخارجي ولم اعرف كيف اعدله

انا سأقوم بتكرار الملف لأكثر من صف وأكثر من شعبة 

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

بارك الله بكم

ولا زلت أعمل على الملف وسأحاول تعديل كود ترتيب الأوائل بحسب ملاحظتك السابقة

ترتيب التلاميذ تصاعديا (1) - Copy.xlsm

[محمد هشام.]

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

اقتراحات من الممكن أن تستفيد منها  سواءا للترتيب أو حفظ الملف 

Sub ExportToPDF()
    Dim endNum As Long, wb As Workbook, WS As Worksheet, i As Long
    Dim nFichier As String, chemin As String, r As String, n As Integer
    
    Set WS = Sheets("الشهادة")
    
    If IsEmpty(WS.Range("H2").Value) Then MsgBox "الرجاء تحديد إجمالي الشهادات", vbExclamation: Exit Sub
    
    With Application
        .ScreenUpdating = False: .EnableEvents = False: .DisplayAlerts = False
    
    startNum = WS.[F2].Value: endNum = WS.[H2].Value
    
    Set wb = Workbooks.Add(xlWBATWorksheet)
    chemin = ThisWorkbook.Path & "\الشهادات\"
    If Len(Dir(chemin, vbDirectory)) = 0 Then MkDir chemin
    
    nFichier = WS.[B6].Value & "_" & WS.[B7].Value & ".pdf"
    r = chemin & nFichier
    
    If Len(Dir(r)) > 0 Then
        n = 1
        Do
            r = chemin & WS.[B6].Value & "_" & WS.[B7].Value & "(" & n & ").pdf"
            n = n + 1
        Loop Until Len(Dir(r)) = 0
    End If

    For i = 1 To endNum
        WS.[F2].Value = i
        WS.Copy After:=wb.Worksheets(wb.Worksheets.Count)
    Next i
    
    WS.[F2].Value = 1
    wb.Worksheets(1).Delete
    wb.ExportAsFixedFormat Type:=xlTypePDF, FileName:=r
    wb.Close False
    
        .ScreenUpdating = True: .EnableEvents = True: .DisplayAlerts = True
    End With
    
    MsgBox "تم تصدير الشهادات بنجاح في " & vbCrLf & vbCrLf & _
        r, vbInformation, "تم حفظ الشهادات من " & startNum & " إلى " & endNum
End Sub

 

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Me.Range("B7:S36")) Is Nothing Then
        Dim WS As Worksheet, i As Long, j As Long, n As Long, ky As Long, a() As Variant, tmp As Long, tbl As String
        Set WS = ActiveSheet
        Application.ScreenUpdating = False
        WS.Range("Y7:AA36").ClearContents
        
        For i = 7 To 36
            If Len(Trim(WS.Cells(i, "B").Value)) > 0 And _
            Len(Trim(WS.Cells(i, "S").Value)) > 0 And WS.Cells(i, "S").Value > 0 Then tmp = tmp + 1
        Next i
        If tmp = 0 Then MsgBox "لا توجد بيانات", vbExclamation: Exit Sub
        
        ReDim a(1 To tmp, 1 To 3)
        tmp = 0
        For i = 7 To 36
            If Len(Trim(WS.Cells(i, "B").Value)) > 0 And _
            Len(Trim(WS.Cells(i, "S").Value)) > 0 And WS.Cells(i, "S").Value > 0 Then
                tmp = tmp + 1
                a(tmp, 1) = WS.Cells(i, "A").Value: a(tmp, 2) = WS.Cells(i, "B").Value: a(tmp, 3) = WS.Cells(i, "S").Value
            End If
        Next i
        
        For i = 1 To tmp - 1
            For j = i + 1 To tmp
                If a(i, 3) < a(j, 3) Then
                    r a(i, 1), a(j, 1): r a(i, 2), a(j, 2): r a(i, 3), a(j, 3)
                End If
            Next j
        Next i
        
        n = 1: ky = 1
        WS.Cells(7, "Y").Value = 1: WS.Cells(7, "Z").Value = a(1, 2): WS.Cells(7, "AA").Value = "الأول"
        
        For i = 2 To tmp
            If a(i, 3) = a(i - 1, 3) Then
                ky = ky + 1
                tbl = GetTex(n, ky)
                WS.Cells(i + 6, "AA").Value = tbl
            Else
                n = n + 1: ky = 1
                tbl = GetTex(n, ky)
                WS.Cells(i + 6, "AA").Value = tbl
            End If
            WS.Cells(i + 6, "Y").Value = i: WS.Cells(i + 6, "Z").Value = a(i, 2)
        Next i
        
        Application.ScreenUpdating = True
    End If
End Sub
Sub r(ByRef a As Variant, ByRef b As Variant)
    Dim temp As Variant
    temp = a: a = b: b = temp
End Sub
Function GetTex(n As Long, ky As Long) As String
    GetTex = tmps(n) & IIf(ky > 1, " " & ky, "")
End Function

 

 

ترتيب التلاميذ تصاعديا V2.xlsm

تم تعديل فبراير 8 بواسطه محمد هشام.

[عبدالله بشير عبدالله]

السلام عليكم

نم تعديل كود خفظ الشهادة يحيت يحفظ  باسم الفصل والشعبة حسب ما هو مكتوب في الخليتين b6&b7 ولم يعد التغيير من الكود

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

اذا كان المقصود كلمة مكرر ينم الغائها فالملف المرفق فيه طلبك

وان كنل تعنى شئ اخر فاوضح لي الامر

ترتيب التلاميذ تصاعديا (1) - Copy.xlsm

 

تم تعديل فبراير 8 بواسطه عبدالله بشير عبدالله

[abou_stef]

أسأل الله ان ينور دربكم ويوفقكم

شكرا لكم جميعا