اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

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


الردود الموصى بها

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

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


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

  • Like 1
رابط هذا التعليق
شارك

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

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

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

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

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

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

 

مصطفى.jpg

رابط هذا التعليق
شارك

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

صحح الجزئية التالية في الكود 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

بن علية حاجي

  • Like 1
رابط هذا التعليق
شارك

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

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

  • Like 1
رابط هذا التعليق
شارك

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

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

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

تحياتي لكم:fff:

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

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

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

تحياتي لكم:fff:

رابط هذا التعليق
شارك

  • 1 month later...

من فضلك سجل دخول لتتمكن من التعليق

ستتمكن من اضافه تعليقات بعد التسجيل



سجل دخولك الان
  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information