ترتيب ارقام بطريقة معينة

[محمد احمد العصري]

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

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

على سبيل المثال الارقام التالية 

17_1_481

17_1_4200

17_1_92

17_1_172

17_1_103

17_1_41

17_1_263

17_1_237

17_1_7

17_1_1676

17_1_4094

17_1_1213

17_1_4045

17_1_1163

17_1_568

17_1_67

17_1_830

17_1_159 احتاج ان ترتب  اولا الرقم 17 ثم الرقم 1 ثم الاصغر او الاكبر من تلك الارقام  والترتيب اما تصاعديا واما تنازليا بنفس المعيار  علما بان الرقم 17 يعني  العام وقديكون16 او20 والرقم 1 رقم الصف والرقم الذي يلية رقم الطالب .وجزاكم الله خير

 

 

 

[سليم حاصبيا]

يا صديقي 

أقل شيء يمكن ان تعمله هو رفع ملف بما تريد

ولا تدع من يريد المساعدة ان ينشأ لك ملفاً بهذا الموضوع(احتراماً للوقت ليس الا)

الكود المطلوب  (العامود D الفرز تنازلي   العامود E الفرز تصاعدي)

Option Explicit
Sub Salim_Order()
Dim Mmax%, i%, x%
Dim S_lst As Object
Dim Txt

Set S_lst = CreateObject("System.Collections.SortedList")

With Sheets("Salim")
    If .Range("D1").CurrentRegion.Rows.Count > 1 Then
      .Range("D1").CurrentRegion.Offset(1). _
      Resize(.Range("D1").CurrentRegion.Rows.Count - 1). _
      ClearContents
     End If
    
    Mmax = .Cells(Rows.Count, 1).End(3).Row
    i = 2
   Do Until i = Mmax + 1
   If .Range("A" & i) <> vbNullString Then
      Txt = Split(.Range("A" & i), "_")
      If Not S_lst.Contains(CInt(Txt(2))) Then
       S_lst.Add CInt(Txt(2)), "_" & Txt(1) & "_" & Txt(0)
      End If
    End If
      i = i + 1
  Loop
   
    x = 2
      For i = S_lst.Count - 1 To 0 Step -1
        Cells(x, 4) = S_lst.GetKey(i) & S_lst.GetByIndex(i)
        x = x + 1
     Next
   
   x = 2
      For i = 0 To S_lst.Count - 1
        Cells(x, 5) = S_lst.GetKey(i) & S_lst.GetByIndex(i)
        x = x + 1
      Next
     
 End With
Set S_lst = Nothing
 End Sub

الملف مرفق (اضغط فقط غلى الزر ٌRun)

Assri_Ahmad.xlsm

[محمد احمد العصري]

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

ملف العمل.xlsx

[سليم حاصبيا]

كان يجب من البداية  ادراج الملف ولا ضرورة لاضاعة الوقت

Option Explicit
Sub Salim_Order()
Dim Mmax%, i%, x%
Dim S_lst As Object
Dim Txt
Dim Ar(), itm
Ar = Array(17, 16, 15, 14, 13, 12, 11)
x = 1
Set S_lst = CreateObject("System.Collections.SortedList")

With Sheets("Salim")
.Range("f1").CurrentRegion.ClearContents

   Mmax = .Cells(Rows.Count, 1).End(3).Row
 
 For Each itm In Ar
    i = 1
   Do Until i = Mmax + 1

   If Left(.Range("A" & i), 2) = CStr(itm) Then
      Txt = Split(.Range("A" & i), "_")
        S_lst.Add CInt(Txt(2)), .Range("A" & i)
    End If
      i = i + 1
  Loop
      For i = S_lst.Count - 1 To 0 Step -1
        .Cells(x, 6) = S_lst.GetByIndex(i)
       
        x = x + 1
     Next
S_lst.Clear

Next itm
       .Range("G1").Resize(x - 1).Formula = _
          "=INDEX($B$1:$B$100,MATCH(F1,$A$1:$A$100,0))"
       .Range("F1").CurrentRegion.Value = _
       .Range("F1").CurrentRegion.Value
End With

Set S_lst = Nothing
 End Sub

 

AhMad_Assri.xlsm

[محمد احمد العصري]

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

[طارق محمود]

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

أخي / محمد احمد العصري
يمكنك الحل عن طريق فصل العمود إلي ثلاث أعمدة
ثم ترتبها كما تريد
أنظر الصورة