ترتيب الاسماء حسب القيم المختارة

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

الاخوة الأعزاء السلام عليكم ورحمة الله وبركاته .. لقد قمت بالبحث عن كود يقوم بترتيب الاسماء أبجدياً حسب القيم المعطاة

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

ترتيب الاسماء1.rar

[ياسر خليل أبو البراء]

ممكن توضيح بمثال تطبيقي ويا ريت تذكر الأسماء اللي عايز ترتب على أساسهم

أنا عندي تقريباً الحل لكن لم تكتمل المعطيات بالنسبة لي

شوية شرح بالتفصيل

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

الشرح موجود  داخل ملف أكسل  المرفق السابق .. ولكن الشرح  سوف اقوم بشركة مرة أخرى ..

على سبيل مثال  عندي جدول مكون  من 10 أعمدة  حيث كل عمود يعني نوع من القيم  ( الاسم  - الجنس - رقم الهوية - مكان الميلاد - الجنسية - اللغة - المؤهل التعليمي  - ملاحظات )

وعدد الاشخاص  تقريباً 500 شخص ..

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

1- دكتور

2- ماجستير

3-  بكالوريوس

4- دبلوم

5- ثانوية عامة

 

تكملة للسابق . يعني أن في الجدول  500 صف  و 10 أعمدة   // ويتم فرز  الأشخاص حسب  المؤهل

عند النقر على الزر

يقوم بفرز

اول  شئ   اصحاب الشهادات الدكتور 

ثاني شئ  اصحاب الشهادات   الماجستير

ثالث شي أصحاب الشهادات  البكالوريوس

وهكذا

 

 

[ياسر خليل أبو البراء]

أخي الكريم محمد الزريعي

يفضل دائماً أن يكون الملف معبر عن الطلب ..لما لم تضع الملف كما وصفت في مشاركتك السابقة بشكل مباشر ..

عموماً يرجى الإطلاع على التوجيهات لمعرفة كيفية التعامل مع المنتدى

 

إليك الكود التالي وإن شاء المولى يفي بالغرض

Sub SortCustomList()
    Dim I As Long, LR As Long, vArray() As Variant
    
    vArray = Array("دكتور", "ماجستير", "بكالوريوس", "دبلوم", "ثانوية عامة")
    LR = Cells(Rows.Count, 1).End(xlUp).Row
    
    Application.AddCustomList vArray
    Range("A6:K" & LR).Sort Key1:=Range("G6:G" & LR), OrderCustom:=Application.CustomListCount + 1, Header:=xlYes
    Application.DeleteCustomList Application.CustomListCount
End Sub

Sort Custom List YasserKhalil.rar

تم تعديل أغسطس 5, 2015 بواسطه ياسر خليل أبو البراء

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

شكرا لك اخي ياسر خليل .. ..  جاري الان  تجربة الكود ..

 

 

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

نعم أخي العزيز ..  الله يجزيك خير هذا هو الكود المطلوب ..

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

أقصد اريدة أن يرتب  االذين يحمل

1- شهادة دكتور  وجنسيته سعودي  وعمرة  35 الاول .  لا نه عندنا نظام سعودة .

2-  اشهادة دكتور وجنسيته  سعودي  وعمرة 30 الثاني

3- شهادة دكتور وجنسية  عربي وعمرة  35 الثالث

4- شهادة دكتور وجنسية  غير عربي وعمرة 35 الرابع

 

يعني الاولويات في الترتيب هي ( اول شئ الشهادة - ثاني شئ  الجنسية ... وثالث شي العمر )

 

اسف لو ازعجتك  يا أخي  الاستاذ /  ياسر خليل

 

وشكرا على  ابداعك  الاول

[ياسر خليل أبو البراء]

أخي الكريم يفضل إرفاق الملف الأصلي لمحاولة المساعدة ..حيث أن الأمر غير واضح الآن

هل الترتيب على العمود الخاص بالجنسية ترتيب أبجدي أم ترتيب مخصص كما فعلنا في عمود المؤهل .. وعمود العمر هل الترتيب تنازلي أم تصاعدي ؟؟؟

لابد من التوضيح التام للطلب لكي يسهل المساعدة

يرجى الإطلاع على التوجيهات لمعرفة كيفية التعامل مع المنتدى

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

اخي العزيز / هذا الملف مرفق به كل شئ  علماً انني قمت على تعديل الكود  ( من ناحية الاعمدة ) .

الملف عبارة عن 3 صفحات

والمطلوب هو صفحة واحدة وأنا زوت الصفحات لكي يكون عندك نسخة احتياطية  في الصفحة الاولى .. ووضعت في الصفحة الثانية  وهي الصفحة التي يجرى عليها الكود والصفحة الثالثة هي عبارة عن النتيجة التي نريدها بعد تنفيذ الكود .

شاكر ومقدر لكم

Sort Custom List YasserKhalil.rar

[ياسر خليل أبو البراء]

جرب الكود بهذا الشكل ..

Sub SortCustomList()
    Dim I As Long, J As Long, K As Long, LR As Long
    Dim Arr1, Arr2, ArrOut
    
    Arr1 = Array("دكتور", "ماجستير", "بكالوريوس", "دبلوم", "ثانوية عامة")
    Arr2 = Array("سعودي", "عربي", "غير عربي")
    
    ReDim ArrOut(0 To 14)
    For I = 0 To UBound(Arr1)
        For J = 0 To UBound(Arr2)
            ArrOut(K) = Arr1(I) & " " & Arr2(J)
            K = K + 1
        Next J
    Next I

    LR = Cells(Rows.Count, 1).End(xlUp).Row
    
    Application.ScreenUpdating = False
        With Range("J7:J" & LR)
            .Formula = "=TRIM(H7) & "" "" & TRIM(F7)": .Value = .Value
        End With
        
        Application.AddCustomList ArrOut
        Range("A6:I" & LR).Sort Key1:=Range("J6:J" & LR), OrderCustom:=Application.CustomListCount + 1, Key2:=Range("I6:I" & LR), Order2:=xlDescending, Key3:=Range("B6:B" & LR), Order3:=xlAscending, Header:=xlYes
        Columns("J:J").Delete
        Application.DeleteCustomList Application.CustomListCount
    Application.ScreenUpdating = True
End Sub

 

تم تعديل أغسطس 8, 2015 بواسطه ياسر خليل أبو البراء

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

شكراً لك أبو البراء .. تم نسخ الكود وجاري الان التجربة ..

 

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

نعم  هذا هو المطلوب وجزاك الله الف خير .. أنا مبتدئ في  الاكسل   واريد  ان اوضح شرح الكود  أكثر  للأخرين  لكي يستفيدو منه .

1-  وهو  ReDim ArrOut(0 To 14)    

تقوم بزيادة الرقم 14 أذا كان هناك زيادة في عدد الجنسيات أو عدد الشهادات  راح يكون الرقم أكبر .. وحالياً  يعني ( 3*5=15 ) اكتب  15 عادي  .. ولكن أذا كان الرقم  10 راح يعطيك خطاء ..

2- قم بتعديل  هذا الجزء  With Range("J7:J" & LR)

وهذا  بعد  اخر عمود  للجدول وهو أول عمود فارغ في نهاية الجدول لان البرنامج راح يحذف الاعمدة من هذا الموقع .

3- تحتة مباشرة Formula = "=TRIM(H7) & "" "" & TRIM(F7)": .Value = .Value

وهذا الكود مهم  ما عليك تغير  h7  و f7  >>  حيث يرمز لـ H7  العمود H  والسطر السابع ..  ويمكنك تغيرة الي أي عمود اخر  كما أن H7  هو  المؤهل في هذا الجدول الذي سوف نقوم بالفرز علية وأن f7  الجنسية

4-  وهو كود طويل  لكن يحتاج الي تركيز شوي فهو بسيط   Range("A6:I" & LR).Sort Key1:=Range("J6:J" & LR), OrderCustom:=Application.CustomListCount + 1, Key2:=Range("I6:I" & LR), Order2:=xlDescending, Key3:=Range("B6:B" & LR), Order3:=xlAscending, Header:=xlYes

 هذا الكود  غير فقط اللون الأخضر ..  حيث أن الاول يعني الصف من a6  وحتى l  في نهاية الشيت ، ... والرنج الثاني من j6  وهو اول عمود على يسار الجدول ومن الصف السادس وحتى نهاية هذا العمود .

كما l6 الي l  يرمز الي القيم العمرية في هذا الجدول ..

وأخيراً في هذا الكود هو  بداية السطر الذي سوف ينقل منه  البيانات وهنا وضع الاستاذ B6  وحتى نهاية  البيانات  وبإمكان أي شخص يضع من العمود الاول وهو a6  وربما يكون الصوف عندهم اقل من 6 ربما تكون 2

 

 5-  اخر شئ  هنا  وهو عملية الحذف Columns("J:J").Delete

اكتب بدل J:j   أسم اول عمود يبداء الكمبيوتر بالحذف منة  ويكن  t: t  أو أي عمود اخر بعد الجدول

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

[ياسر خليل أبو البراء]

أخي الكريم محمد الزريعي

الحمد لله أن تم المطلوب على خير ..

بارك الله فيك على التوضيح والتفكير بصوت عالي ، وأي شيء تحت أمرك في توضيحه وتفصيله

أخيراً يرجى تحديد أفضل إجابة ليظهر الموضوع مجاب ومنتهي ...

ويا ريت تقوم بالإطلاع على رابط التوجيهات في الموضوعات المثبتة

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

ماهي روابط التوجيهات أخي .. مافهمتها ؟

[ياسر خليل أبو البراء]

هذا الرابط

من هنا

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

الأخ ياسر خليل أبو البراء ..

لقد احتجت هذا الكود مرة أخرى ..  بحيث أن 

عدد Arr1 = 20

عدد Arr2= 50

ولقد سويت  كما هو مشروح ولكن لم يتنفذ الكود .. يقف  عند   Application.AddCustomList ArrOut    باللون الأصفر

مش عارف ايش السبب .. هل لهذا الكود عدد معين  يتوقف عندها .

[ياسر خليل أبو البراء]

أخي الكريم محمد الزريعي

في هذه الحالة ستقوم بضرب 20 * 50 = 1000 .. فوجب التعديل على السطر التالي

ReDim ArrOut(0 To 14)

ليصبح بهذا الشكل

ReDim ArrOut(0 To 999)

أرجو أن يكون المطلوب

 

قد تكون المشكلة في أن هناك حد أقصى لعدد القوائم المخصصة ..أعتقد أن الأمر سيحتاج لتناول الموضوع من جديد بوجهة نظر جديدة

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

بعد تعديل الرقم هذا يتوقف تنفيذ الكود عند السطر التالي

 Application.AddCustomList ArrOut

باللون الأصفر . وتظهر رسالة خطاء .

[ياسر خليل أبو البراء]

اقتباس

قد تكون المشكلة في أن هناك حد أقصى لعدد القوائم المخصصة ..أعتقد أن الأمر سيحتاج لتناول الموضوع من جديد بوجهة نظر جديدة

 

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

لقد قام الأستاذ القدير /  ياسر خليل   بحل المشكلة التي ظهرت معنا في هذا الرابط التالي :