اريد ضبط هذة المعادلة

[egymina2012]

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

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

لابلبلبلبلبلب.xlsx

[hegazee]

كيف يتم ادراج التقدير تلقائيا و لانعرف هل هذا التقدير يستحق مرتبة شرف أم لا؟

[Foksh]

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

مشاركة مع أخي حجازي ، جرب أن تقوم بتعديل أي نسبة مئوية وراقب الترتيب والفرز هل هو صحيح ومضبوط كما تريد ؟؟

 

SortBy2Way.xlsm

 

وهذا حل آخر باستخدام ماكرو أكثر وضوح ويدعم معك التراجع على عكس الحل السابق الأول 😅

لابلبلبلبلبلب.xlsm

تم تعديل بالامس في 11:29 بواسطه Foksh

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

مغلمنا Foksh الفاضل

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

مع ملاحظة ان النطاق للفرز الى  .SetRange ws.Range("A1:M" & lastRow)  وليس .SetRange ws.Range("A1:L" & lastRow)
كما ارجو تعديل التقديرات حسب فهمي لتقسيم التقديرات من الملف   ان تكون التقديرات هكذا 

 لك كل التقدير والاحترام 

                Select Case Cell.Value
                    Case Is >= 92
                        Cell.Offset(0, -1).Value = "ممتاز مع مرتبة الشرف"
                    Case Is >= 90
                        Cell.Offset(0, -1).Value = "ممتاز"
                    Case Is >= 85
                        Cell.Offset(0, -1).Value = "جيد جداً مع مرتبة الشرف"
                    Case Is >= 75
                        Cell.Offset(0, -1).Value = "جيد جداً"
                    Case Is >= 65
                        Cell.Offset(0, -1).Value = "جيد"
                    Case Is >= 50
                        Cell.Offset(0, -1).Value = "مقبول"
                    Case Else
                        Cell.Offset(0, -1).Value = "مقبول س"
                End Select

 

[Foksh]

20 دقائق مضت, عبدالله بشير عبدالله said:

مع ملاحظة ان النطاق للفرز الى  .SetRange ws.Range("A1:M" & lastRow)  وليس .SetRange ws.Range("A1:L" & lastRow)

ملاحظتك صحيحة أخي وأستاذنا عبدالله ، جزاك الله خيراً على ذكرها . ولكني حين قمت بالتطبيق ارتأيت وبما أنه العمود M هو معادلة مقرونة برقم الصف فلم ألتفت لها ، ولم ألق لها بالاً -رغم تجربتي لها- ولكن لا يضر أن نقوم بالتصويب .. 

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

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

[egymina2012]

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

عند وضع او تغيير النسبة المئوية فان الصف باكملة يذهب الي مكانة وهذا المطلوب لكن 

هناك نقطتان هل يمكن ادراجهما 

1- عند صعود الصف يصعد بدون ترتيب التسلسلي  يصعد بنفس رقم الصف 

2- عند اضافة النسبة هل يمكن اضافة التقدير تلقائي 

50الي 64 مقبول 

65 الي 75 جيد 

75.1 الي 85 جيد جدا 

85.1 الي 90 جيد مع مرتبة الشرف 

90.1 الي 92 ممتاز 

92.1 الي 100 ممتاز مع المرتبة 

3- ارغب في دالة تفقيط المبلغ باللغة العربية جنية وقرش 

 

تم تعديل منذ 7 ساعات بواسطه egymina2012

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

 

4 ساعات مضت, egymina2012 said:

1- عند صعود الصف يصعد بدون ترتيب التسلسلي  يصعد بنفس رقم الصف 

 

قم بتحميل الملف الثاني للاستاذ Foksh به اعادة ترتيب التسلسلي وبه التقديرات يمكنك تعديلها بالكود

4 ساعات مضت, egymina2012 said:

85.1 الي 90 جيد مع مرتبة الشرف 

 

اعتقد ان التقييم غير صحيح ربما تقصد جيدجدا مع مرتبة الشرف

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

[Foksh]

استبدل الدالة الكاملة السابقة ، بهذا التعديل :-

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim cell As Range
    Dim pctCol As Range
    Dim pct As Double
    Dim grade As String
    Dim i As Long
    
    Set ws = Me
    lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
    If lastRow < 2 Then Exit Sub
    
    Set pctCol = Intersect(Target, ws.Range("F2:F" & lastRow))
    
    If Not pctCol Is Nothing Then
        On Error GoTo CleanUp
        Application.ScreenUpdating = False
        Application.EnableEvents = False
        
        For Each cell In pctCol
            If IsNumeric(cell.Value) And cell.Value <> "" Then
                pct = CDbl(cell.Value)
                Select Case pct
                    Case Is >= 92.1: grade = "ممتاز مع المرتبة"
                    Case Is >= 90.1: grade = "ممتاز"
                    Case Is >= 85.1: grade = "جيد مع مرتبة الشرف"
                    Case Is >= 75.1: grade = "جيد جدا"
                    Case Is >= 65:   grade = "جيد"
                    Case Is >= 50:   grade = "مقبول"
                    Case Else:       grade = "راسب"
                End Select
                ws.Cells(cell.Row, "E").Value = grade
            End If
        Next cell
        
        With ws.Sort
            .SortFields.Clear
            .SortFields.Add Key:=ws.Range("F2:F" & lastRow), _
                SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
            .SortFields.Add Key:=ws.Range("B2:B" & lastRow), _
                SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            
            .SetRange ws.Range("A1:M" & lastRow)
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .Apply
        End With
        
        For i = 2 To lastRow
            If ws.Cells(i, "B").Value <> "" Then
                ws.Cells(i, "A").Value = i - 1
            End If
        Next i
        
CleanUp:
        Application.EnableEvents = True
        Application.ScreenUpdating = True
    End If
End Sub

 

الملف بعد التعديل :-

لابلبلبلبلبلب.xlsm