فرز الأسماء بأربعة معايير

[مصطفى محمود مصطفى]

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

الكود التالي للاستاذ ياسر خليل جزاه الله خيرا

Sub SortData()
    Dim LR As Long
    LR = Range("C" & Rows.Count).End(xlUp).Row
    Range("C15:G1015" & LR).Sort Key1:=Range("G16:G1015" & LR), Order1:=xlAscending, Key2:=Range("E15:E1015" & LR), Order2:=xlAscending, Key3:=Range("F16:F1015" & LR), Order3:=xlAscending, Key4:=Range("D16:D1015" & LR), Order4:=xlAscending, Header:=xlYes
End Sub

حاولت اغير المعايير من ثلاثة الى اربعة يعطي خطا

ارجو التعديل عليه

او اي كود اخر يقوم بنفس الغرض

وفقكم الله

مع وافر الاحترام والتقدير

فرز باربع معايير.xlsm

[احمد بدره]

تفضل كود يفي بالغرض

ملحوظة إذا أردت نقل الكود لملف آخر  أو إلى ورقة عمل أخرى قم بتغيير اسم ورقة العمل التي بالكود الملونة باللون الأحمر  إلى اسم ورقة العمل المراد العمل عليها 

If ActiveSheet.Name <> "ورقة1" Then Exit Sub

 

 

فرز باربع معايير.xlsm

[مصطفى محمود مصطفى]

احسنتم استاذ احمد

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

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

[مصطفى محمود مصطفى]

استاذ احمد وفقكم الله

عند فرز اسماء في ملفي وكانت العمود G فارغ في بعض الحقول

وكانت بيانات في الصف 1015 او اقل بقليل يحدث خطا ولا يفرز الاسماء التي وقعت بالاخير 

هل يمكن حل مشكلة الفراغات ومشكلة الاسماء التي تسقط احيانا بالاخير فلا يقوم بفرزها مع بقية الاسماء

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

فرز اجابةباربع معايير.xlsm

 

[بن علية حاجي]

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

صحح الجزئية التالية في الكود G1015" & LR بالجزئية : G" & LR بمعنى حذف الرقم 1015 في الأمر الملزن بالأصفر ثم في الأوامر (الثلاثة) التي تليه...

والكود يصبح كالتالي:

Sub Macro1()
If ActiveSheet.Name <> "ورقة1" Then Exit Sub
 Dim LR As Long
    LR = Range("C" & Rows.Count).End(xlUp).Row
    Range("C16:G" & LR).Select
    
   ActiveWorkbook.ActiveSheet.Sort.SortFields.Clear
   ActiveWorkbook.ActiveSheet.Sort.SortFields.Add Key:=Range("G16:G" & LR) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
   ActiveWorkbook.ActiveSheet.Sort.SortFields.Add Key:=Range("E16:E" & LR) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
   ActiveWorkbook.ActiveSheet.Sort.SortFields.Add Key:=Range("F16:F" & LR) _
        , SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
   ActiveWorkbook.ActiveSheet.Sort.SortFields.Add Key:=Range("D16:D" & LR) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.ActiveSheet.Sort
        .SetRange Range("C16:G" & LR)
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Range("C14").Select
End Sub

بن علية حاجي

[احمد بدره]

تفضل الكود المعدل

Sub Macro1()
If ActiveSheet.Name <> "ورقة1" Then Exit Sub

    Range("C16:G1015").Select
    
   ActiveWorkbook.ActiveSheet.Sort.SortFields.Clear
    ActiveWorkbook.ActiveSheet.Sort.SortFields.Add Key:=Range("G16:G1015") _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.ActiveSheet.Sort.SortFields.Add Key:=Range("E16:E1015") _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
   ActiveWorkbook.ActiveSheet.Sort.SortFields.Add Key:=Range("F16:F1015") _
        , SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    ActiveWorkbook.ActiveSheet.Sort.SortFields.Add Key:=Range("D16:D1015") _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.ActiveSheet.Sort
        .SetRange Range("C16:G1015")
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Range("C14").Select
End Sub

[مصطفى محمود مصطفى]

الاستاذ الفاضل بن علية حاجي حفظكم الباري عز وجل

تعديل اكثر من رائع ويعمل بشكل ممتاز

وفقكم الله وجعله في ميزان حسناتك

تحياتي لكم

الاستاذ العزيز احمد المبدع حفظكم الباري عز وجل

تعديلكم للكود روعة ويعمل بشكل ممتاز

وفقكم الله وجعله في ميزان حسناتكم

تحياتي لكم

[علة لخضر]

محاولة و لكن بالمعادلات ...

ملاحظة .. ألغيتُ المعيار الرابع لأنه متعلق بالاسماء التي تريد جلبها

فرز بثلاث معايير.xlsm

[مصطفى محمود مصطفى]

شكرا لكم اخي علة لخضر

وفقكم الله 

لكم تحياتي

[علة لخضر]

العفو .مصطفى-محمود-مصطفى

وفقكم الله ...شكرا لك

تم تعديل نوفمبر 1, 2018 بواسطه علة لخضر