الترتيب على اساس ثلاث شروط

[بلانك]

المطلوب بالملف

ترتيب الاوائل.xlsx

تم تعديل الثلاثاء at 22:37 بواسطه بلانك

[بلانك]

بالنسبةللترتيب من المجموع الأكبر الى الأصغر اي تنازلي

وبالنسبة للسن من الأصغر سنا الى الأكبر سنا

وبالنسبة لحروف الهجاء من الألف إلى الياء

[محمد هشام.]

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

جرب هدا 

Option Explicit
Sub StringSort()
    Dim WS As Worksheet, lastRow As Long
    
    Set WS = Sheets("Sheet1")
    Application.ScreenUpdating = False
    lastRow = WS.Columns("A:E").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
    
    With WS.Sort
        .SortFields.Clear
        .SortFields.Add2 Key:=WS.Range("C2:C" & lastRow), Order:=xlDescending
        .SortFields.Add2 Key:=WS.Range("D2:D" & lastRow), Order:=xlAscending
        .SortFields.Add2 Key:=WS.Range("E2:E" & lastRow), Order:=xlAscending
        .SetRange WS.Range("A1:E" & lastRow)
        .Header = xlYes
        .Apply
    End With
  Application.ScreenUpdating = True

End Sub

 

[بلانك]

استاذي / محمد هشام عفوا  الكود يعطي خطا لاحظ الصورة

[محمد هشام.]

غريب الكود يشتغل معي بشكل جيد 

 

اليك حل اخر  لاختيار ما يناسبك 

Option Explicit
Sub SortArray()
    Dim a() As Variant, i As Long, j As Long, col As Long
    Dim temp As Variant, lastRow As Long, OnRng As Range
    Dim WS As Worksheet: Set WS = Sheets("Sheet1")
    
    lastRow = WS.Cells(WS.Rows.Count, 1).End(xlUp).Row
    Set OnRng = WS.Range("A1:E" & lastRow)
    a = OnRng.Value
    
      For i = 2 To UBound(a, 1) - 1
        For j = i + 1 To UBound(a, 1)
            If a(i, 3) < a(j, 3) Then
                For col = 1 To UBound(a, 2)
                    temp = a(i, col)
                    a(i, col) = a(j, col)
                    a(j, col) = temp
                Next col
      ElseIf a(i, 3) = a(j, 3) Then
                If a(i, 4) > a(j, 4) Then
                    For col = 1 To UBound(a, 2)
                        temp = a(i, col)
                        a(i, col) = a(j, col)
                        a(j, col) = temp
                    Next col
     ElseIf a(i, 4) = a(j, 4) Then
                    If a(i, 5) > a(j, 5) Then
                        For col = 1 To UBound(a, 2)
                            temp = a(i, col)
                            a(i, col) = a(j, col)
                            a(j, col) = temp
                        Next col
                    End If
                End If
            End If
        Next j
    Next i
    OnRng.Value = a
End Sub

 

ترتيب الاوائل v2.xlsb

[بلانك]

الاوفيس عندي 2010 يمكن هو السبب في الكود الاول لايعمل . اما الكود الثاني يعمل وحميل ولكن ترتيب السن من الاكبر الى الاصغر وانا اريدة من الاصغر سنا الى الاكبر سنا لاحظ الصورة .عند تساوي الطلبه في المجموع يتم ترتيبهم على حسب السن من الاصغر الى الاكبر ولو تساو في السن يتم الترتيب على اساس حروف الهجاء . يارب يكون وضحت الفكرة ....ورمضان كريم عليك

[بلانك]

هل يمكن تعديل الكود الاول ليتماشى مع اوفيس 2010 لن كود سهل وبسيط

تم حل مشكلة السن في الكود الثاني باني غيرت من كود حضرتك من علامة اكبر الى اصغر من < الى  >

[mahmoud nasr alhasany]

Sub StringSort()

    Dim WS As Worksheet
    Dim lastRow As Long
    Dim sortRange As Range

    ' اسم ورقة العمل (يمكن تغييره)
    Const SHEET_NAME As String = "Sheet1"

    Application.ScreenUpdating = False

    ' التحقق من وجود ورقة العمل
    On Error Resume Next
    Set WS = ThisWorkbook.Sheets(SHEET_NAME)
    On Error GoTo 0

    If WS Is Nothing Then
        MsgBox "ورقة العمل '" & SHEET_NAME & "' غير موجودة.", vbExclamation
        GoTo Cleanup
    End If

    ' العثور على الصف الأخير في العمود A
    lastRow = WS.Range("A" & WS.Rows.Count).End(xlUp).Row

    ' التحقق من وجود بيانات
    If lastRow < 2 Then
        MsgBox "لا توجد بيانات للفرز.", vbExclamation
        GoTo Cleanup
    End If

    ' تحديد نطاق الفرز
    Set sortRange = WS.Range("A1:E" & lastRow)

    With WS.Sort
        .SortFields.Clear
        With .SortFields
            .Add Key:=WS.Range("C2:C" & lastRow), Order:=xlDescending
            .Add Key:=WS.Range("D2:D" & lastRow), Order:=xlAscending
            .Add Key:=WS.Range("E2:E" & lastRow), Order:=xlAscending
        End With
        .SetRange sortRange
        .Header = xlYes
        .Apply
    End With

Cleanup:
    Application.ScreenUpdating = True

End Sub

 

تم تعديل الأربعاء at 18:02 بواسطه mahmoud nasr alhasany

[محمد هشام.]

المفروض أن الكود التالي يشتغل معك 

Sub SortStudents()

    Dim WS As Worksheet
    Dim lastRow As Long
    Dim OnRng As Range

    Set WS = ThisWorkbook.Sheets("Sheet1")

    Application.ScreenUpdating = False
    lastRow = WS.Cells(WS.Rows.Count, 1).End(xlUp).Row

    If lastRow < 2 Then
        Application.ScreenUpdating = True
        Exit Sub
    End If

    Set OnRng = WS.Range("A1:E" & lastRow)

    With WS.Sort
        .SortFields.Clear
        .SortFields.Add Key:=WS.Range("C2:C" & lastRow), Order:=xlDescending
        .SortFields.Add Key:=WS.Range("D2:D" & lastRow), Order:=xlAscending, DataOption:=xlSortNormal
        .SortFields.Add Key:=WS.Range("E2:E" & lastRow), Order:=xlAscending
        .SetRange OnRng
        .Header = xlYes
        .Apply
    End With
    Application.ScreenUpdating = True

End Sub

 

 

 

ترتيب الاوائل v3.xlsb

تم تعديل الأربعاء at 20:15 بواسطه محمد هشام.

[بلانك]

بارك اللهم فيكم على الجهد ورمضان كريم