استخراج القيم الفريدة أي الغير مكررة في نطاق Unique List By Collection

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

كثيراً ما نحتاج لهذا الأمر ألا وهو استخراج القيم الفريدة أي الغير مكررة من نطاق لاستخدامها في نطاق آخر أو ربما نريدها لتعبئة كومبوبوكس أو خلافه.

بفرض أن لديك مجموعة من الأسماء فيها أسماء مكررة في النطاق A2:A15 ، والمطلوب استخراج الأسماء الغير مكررة ووضع النتائج في العمود الثالث.

يمكن استخراج القيم المكررة باستخدام معادلة صفيف (أي يجب الضغط على
Ctrl + Shift + Enter بعد إدخال المعادلة)
نقوم بوضع المعادلة في الخلية H2 على سبيل المثال بهذا الشكل

=IFERROR(IF(A2<>"",INDEX($A$2:$A$15,MATCH(0,COUNTIF($H$1:H1,$A$2:$A$15),0)),""),"")

 
إليكم الكود المستخدم لتنفيذ المهمة ، ويوضع الكود في موديول عادي

Sub Unique_List()
    'تعريف المتغيرات
    Dim Rng As Range
    Dim Cel As Range
    Dim Coll As New Collection
    Dim I As Integer

    'تعيين النطاق المراد استخراج القيم الفريدة منه
    Set Rng = Sheet1.Range("A2:A" & Sheet1.Cells(Rows.Count, 1).End(xlUp).Row)

    'سطر لتجنب حدوث خطأ لأنه عند إضافة عنصر موجود من قبل يحدث خطأ
    On Error Resume Next

    'حلقة تكرارية لكل خلية من خلايا النطاق
    For Each Cel In Rng
        'إضافة العنصر أو قيمة الخلية ويمثل الجزء بعد الفاصلة مفتاح فريد
        'لتحويل قيمة الخلية لقيمة نصية في حالة التعامل مع الأرقام [Cstr] وتم استخدام الدالة
        Coll.Add Cel.Value, CStr(Cel.Value)
    Next Cel

    'وضع قيم الكائن الذي استخدم في تخزين القيم الفريدة في العمود الثالث
    For I = 1 To Coll.Count
        Sheet1.Cells(I + 1, 3).Value = Coll(I)
    Next I
End Sub

تحميل الملف من هنا

إعداد / ياسر خليل أبو البراء