طلب دالة ترتيب قائمة ابجديا وحذف التكرار منها

[ياسر أحمد الشيخ]

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

أريد دالة تقوم بترتيب قائمة ابجديا وحذف التكرار منها

انظر المرفق

Sort_Unique_req.rar

[عبدالله المجرب]

السلام عليكم

جرب المرفق

Sort_Unique_req.rar

[عبدالله المجرب]

المرفق السابق يالمعادلات

وهذا الكود لنفس الغرض

Sub Abu_Ahmed()

[F4:F300].ClearContents

Dim cl As Range

For Each cl In Range("G4:G" & [G15000].End(xlUp).Row)

x = cl.Row

Set myrng = Range("G4:G" & x)

If Application.WorksheetFunction.CountIf(myrng, cl.Value) = 1 Then

Cells([F15000].End(xlUp).Row + 1, 6).Value = cl.Value

End If

Next

End Sub

[ياسر أحمد الشيخ]

شكرا أخى عبد الله المجرب

ولكن هذه الدالة لا تقوم بترتيب القائمة أبجدياً

وشكرا

[عبدالله المجرب]

اخي للترتيب

قم بفرز حسب الابجدية لبيانات المصدر وسيتم الترتيب

[ياسر أحمد الشيخ]

ألا يمكن للدالة القيام بعملية الترتيب تلقائياً

وشكرا

[الـعيدروس]

اي القائمة تريدها ابجديا

Data ام Result

[ياسر أحمد الشيخ]

قائمة result

التى أنشأنا بها الدالة

ولكن أريد الدالة نفسها أن تقوم بحذف المكرر من القائمة وترتيبها أبجدياً

الشيئين معاً

وشكرا

[الـعيدروس]

إستخدم هذا الكود لحذف مكرر عمود G

Public Sub DE_TQRAR()

ActiveSheet.Range("G4:G" & Range("G" & Rows.Count).End(xlUp).Row).RemoveDuplicates Columns:=1, Header:=xlYes

End Sub

[ياسر أحمد الشيخ]

انظر هذه الدالة من عمل الأستاذ يحيى حسين :

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

ضع المعادلة فى خلية F4 ولا تنسى الضغط على Ctrl+Shift+Enter

=INDEX($G$4:$G$12,MATCH(0,COUNTIF($G$4:$G$12,"<"&$G$4:$G$12)-SUM(COUNTIF($G$4:$G$12,"="&$F$3:F3)),0)

هذه الدالة تقوم بالمطلوب (تحذف المكرر وترتب القائمة أبجديا )

ولكنها تغفل آخر عنصر فى القائمة لا تذكره أبداً

هل يمكن حل تلك المشكلة

[يحيى حسين]

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

أخي جرب الدالة التالية

=INDEX($G$4:$G$13,MATCH(0,COUNTIF($G$4:$G$12,"<"&$G$4:$G$12)-SUM(COUNTIF($G$4:$G$12,$F$3:F4)),0))

و هي معادلة صفيف يجب الضغط على

ctrl+Shift+Enter

[ياسر أحمد الشيخ]

شكرا جزيلا يا ملك المعادلات

حل رائع جدا جدا جدا جدا

جدا جدا جدا جدا جدا جدا جدا جدا

جدا جدا جدا جدا

شكرا

تمت الاجابة

[الزير]

انظر هذه الدالة من عمل الأستاذ يحيى حسين :

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

ضع المعادلة فى خلية F4 ولا تنسى الضغط على Ctrl+Shift+Enter

=INDEX($G$4:$G$12,MATCH(0,COUNTIF($G$4:$G$12,"<"&$G$4:$G$12)-SUM(COUNTIF($G$4:$G$12,"="&$F$3:F3)),0)

هذه الدالة تقوم بالمطلوب (تحذف المكرر وترتب القائمة أبجديا )

ولكنها تغفل آخر عنصر فى القائمة لا تذكره أبداً

هل يمكن حل تلك المشكلة

ما دام هذه الدالة موجود لديك من قبل

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

[ياسر أحمد الشيخ]

لكنى لم أكن أعرفها منذ البدايه

[يحيى حسين]

انظر هذه الدالة من عمل الأستاذ يحيى حسين :

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

ضع المعادلة فى خلية F4 ولا تنسى الضغط على Ctrl+Shift+Enter

=INDEX($G$4:$G$12,MATCH(0,COUNTIF($G$4:$G$12,"<"&$G$4:$G$12)-SUM(COUNTIF($G$4:$G$12,"="&$F$3:F3)),0)

هذه الدالة تقوم بالمطلوب (تحذف المكرر وترتب القائمة أبجديا )

ولكنها تغفل آخر عنصر فى القائمة لا تذكره أبداً

هل يمكن حل تلك المشكلة

ما دام هذه الدالة موجود لديك من قبل

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

السلام عليكم

أخي الزير للتوضيح

الأخ السائل

وضع الموضع في المنتديين هنا و في موقعي

http://excel4us.com/vb/showthread.php?t=2227

و قمت بإجابته في موقعي

و بسبب وجود خطأ في ملف الأخ الذي رفعه على موقعي ضن ان هناك خطأ في المعادلة و هو لم يكن خطأ

انما كان سطر مخفي في ملفه

لذلك سحب الاخ المعادلة الي هنا و طلب المساعدة فيها

أرجو ان تكون قد إتضحت الصورة

دمتم في حفظ الله

[abouelhassan]

حصل خير اخوانى

بارك الله فيكم جميعا احترامى وتقديرى لشخصكم الكريم

[ابو مالك ابرش]

 

Sheets("sheet1").Select
Range("v4:b" & Cells(Rows.Count, "b").End(xlUp).Row).Select
ActiveSheet.Range("v4:b" & Cells(Rows.Count, "b").End(xlUp).Row + 1).RemoveDuplicates Columns:=Array(1, 2, 3, 4), _
      Header:=xlNo
  

'=======================================================

 
    Range("v4:b" & Cells(Rows.Count, "b").End(xlUp).Row).Select
    ActiveWorkbook.Worksheets("sheet1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("sheet1").Sort.SortFields.Add Key:=Range("d4:d" & Cells(Rows.Count, "d").End(xlUp).Row) _
         , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("sheet1").Sort.SortFields.Add Key:=Range("b4:b" & Cells(Rows.Count, "b").End(xlUp).Row) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("sheet1").Sort.SortFields.Add Key:=Range("c4:c" & Cells(Rows.Count, "c").End(xlUp).Row) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("sheet1").Sort.SortFields.Add Key:=Range("e4:e" & Cells(Rows.Count, "e").End(xlUp).Row) _
       , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("sheet1").Sort.SortFields.Add Key:=Range("s4:s" & Cells(Rows.Count, "s").End(xlUp).Row) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("sheet1").Sort.SortFields.Add Key:=Range("t4:t" & Cells(Rows.Count, "t").End(xlUp).Row) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("sheet1").Sort
       .SetRange Range("B4:V10000")
       .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
       .SortMethod = xlPinYin
       .Apply
   End With
    Range("B4").Select
      

تم تعديل يوليو 5, 2017 بواسطه ابو مالك ابرش

[ناصر سعيد]

في ١٠‏/١٢‏/٢٠١١ at 13:26, الـعيدروس said:

إستخدم هذا الكود لحذف مكرر عمود G

Public Sub DE_TQRAR()

ActiveSheet.Range("G4:G" & Range("G" & Rows.Count).End(xlUp).Row).RemoveDuplicates Columns:=1, Header:=xlYes

End Sub

 

كود خفيف ومفيد ولكنه يمنع التكرار في نفس صفحه البيانات لو تكون نتيجته في صفحة اخرى يكون رائع

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

بسيطة أخي ناصر ..

قم بإضافة سطر ينسخ العمود إلى ورقة العمل المطلوبة ثم أضف سطر حذف التكرار (يمكن تسجيل ماكرو بعملية النسخ)

[ناصر سعيد]

Sub نسخ()
'
    Sheets("Sheet1").Select
    Range("D7:D150").Select
    Selection.Copy
    Sheets("Sheet4").Select
        Range("F6").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("F7").Select
End Sub

هل يمكن ان يخف عن كده يا استاذ ياسر ؟

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

نعم أخي ناصر .. تسجيل الماكرو يسجل التحديد وهو غير مطلوب في التعامل مع الأكواد حيث يسبب بطء شديد

جرب التالي 

Sub نسخ()
    Sheets("Sheet1").Range("D7:D150").Copy
    Sheets("Sheet4").Range("F6").PasteSpecial Paste:=xlPasteValues
End Sub

 

[ناصر سعيد]

'Public Sub DE_TQRAR()
Sub نسخ()
    Sheets("Sheet1").Range("D7:D150").Copy
    Sheets("Sheet4").Range("G7").PasteSpecial Paste:=xlPasteValues
ActiveSheet.Range("G7:G" & Range("G" & Rows.Count).End(xlUp).Row).RemoveDuplicates Columns:=1, Header:=xlYes

End Sub

هل يوجد اي تعديل حفظك الله  ؟ استاذ ياسر

ما الفرق بين ال SUB  و  Public

    [G7:G500].Sort [G7], xlAscending

اين اضع هذا السطر ؟

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

لا يوجد فرق بين Sub و Public .. لكن الأمر يختلف إذا تم استخدام كلمة Private .. فهذا يعني أن اسم الماكرو لن يظهر في قائمة أسماء الماكرو عند الضغط على Alt + F8 ..

أعتقد سطر الترتيب في النهاية بعد حذف التكرار ..

[ناصر سعيد]

Sub قيم_فريده_مرتبة()
    Sheets("Sheet1").Range("D7:D150").Copy
    Sheets("Sheet4").Range("H7").PasteSpecial Paste:=xlPasteValues
ActiveSheet.Range("H7:H" & Range("H" & Rows.Count).End(xlUp).Row).RemoveDuplicates Columns:=1, Header:=xlYes
 [H7:H500].Sort [H7], xlAscending
End Sub

ربنا يبارك في النافع .. يارب

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

[ناصر سعيد]

Sub قيم_فريده_مرتبة()
    Sheets("Sheet1").Range("D7:D150").Copy
    Sheets("Sheet4").Range("H7").PasteSpecial Paste:=xlPasteFormats
    
ActiveSheet.Range("H7:H" & Range("H" & Rows.Count).End(xlUp).Row).RemoveDuplicates Columns:=1, Header:=xlYes
 [H7:H500].Sort [H7], xlAscending
End Sub

xlPasteFormats

هذه هي نقطه التغيير