إجمالي مرات مشاهدة الصفحة

الاثنين، 3 أكتوبر 2016

استخراج القيم الفريدة مع كل القيم المرتبطة بها List The Unique And Concatenate Corresponding Values

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

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

وبالمثال كما تعودنا يتضح المقال ، حيث أن التطبيق العملي أفضل من الكلام النظري

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


لاحظ شكل النتائج المطلوبة


قبل تنفيذ الكود يجب تفعيل المكتبة التالية من خلال أدوات Tools اختر الأمر References ثم اختر المكتبة المسماة Microsoft Scripting Runtime ، كما هو موضح بالصورة التالية :


إليكم الكود المستخدم لتنفيذ المهمة ، والكود مصحوب بشرح تفصيلي لكي يسهل فهم عمل الكود

'Tools > References > Microsoft Scripting Runtime
'------------------------------------------------

Sub List_Unique_Values()
    'تعريف المتغيرات التي ستستخدم في الكود
    Dim oDict           As Dictionary
    Dim sData()         As Variant
    Dim LastRow         As Long
    Dim I               As Long
    Dim Cnt             As Long
    
    'تعيين قيمة للمتغير لإنشاء الكائن القاموس ويستخدم لتخزين القيم الفريدة
    Set oDict = CreateObject("Scripting.Dictionary")
    
    'سطر لتحديد آخر صف به بيانات
    LastRow = Cells(Rows.Count, "A").End(xlUp).Row
    
    'حلقة تكرارية من الصف الثاني لآخر صف
    For I = 2 To LastRow
    
        'اختبار ما إذا كانت القيمة في العمود الأول موجودة في القاموس أم لا
        'إذا لم تكن موجودة يتم تنفيذ الأسطر التالية
        If Not oDict.Exists(Cells(I, "A").Value) Then
        
            'زيادة قيمة المتغير بمقدار 1 حيث سيتم تمديد البعد الثاني للمصفوفة
            Cnt = Cnt + 1
            
            'تغيير أبعاد المصفوفة : الجزء الأول يمثل البعد الأول
            'الجزء الثاني يمثل البعد الثاني وهو الجزء المتغير
            'للاحتفاظ بالقيم التي كانت موجودة بالمصفوفة من قبل [Preserve] تستخدم كلمة
            ReDim Preserve sData(1 To 2, 1 To Cnt)
            
            'الصف الأول في المصفوفة وفي العمود الأول منها في أول حلقة تكرارية يساوي
            '[I] قيمة الخلية في العمود الأول في الصف الثاني والذي يمثله المتغير
            'حيث مع كل حلقة تكرارية تتغير قيمة المتغيرات
            sData(1, Cnt) = Cells(I, "A").Value
            
            'الصف الثاني في المصفوفة وفي العمود الأول منها في أول حلقة تكرارية يساوي
            '[I] قيمة الخلية في العمود الثاني في الصف الثاني والذي يمثله المتغير
            'حيث مع كل حلقة تكرارية تتغير قيمة المتغيرات
            sData(2, Cnt) = Cells(I, "B").Value
            
            'إضافة عنصر للقاموس والإضافة تكون متبوعة بالقيمة والمفتاح
            'حيث القيمة هنا تمثل القيمة في العمود الأول وهو العمود
            'المطلوب أن يتم استخراج القيم الفريدة له ، ثم المفتاح هنا
            'سيكون بمثابة عداد لهذه القيم
            oDict.Add Cells(I, "A").Value, Cnt
        
        'في حالة أن القيمة في العمود الأول تكررت أي أنها موجودة في القاموس
        'يتم تنفيذ السطر التالي
        Else
            
            'يتم إضافة الرقم في العنصر الفريد أي الغير مكرر إلى الرقم الذي تم تخزينه من قبل
            'ثم يضاف له الرقم الجديد الموجود في العمود الثاني
            sData(2, oDict.Item(Cells(I, "A").Value)) = sData(2, oDict.Item(Cells(I, "A").Value)) & ", " & Cells(I, "B").Value
            
        'نهاية جملة الشرط
        End If
    
    'الانتقال للحلقة التالية أي الصف التالي
    Next I
    
    'بعد الانتهاء من الحلقات التكرارية يكون الناتج عبارة عن مصفوفة بها
    'القيم الفريدة أو الغير مكررة للأسماء في بعد والبعد الآخر به أرقام المبيعات
    
    '[D1:E1] إلى الخلايا [A1:B1] إدراج نفس العناوين من الخلايا
    Range("D1:E1").Value = Array(Range("A1").Value, Range("B1").Value)
    
    '[D2] نقل محتويات المصفوفة إلى ورقة العمل في أول النطاق
    Range("D2").Resize(UBound(sData, 2), 2).Value = WorksheetFunction.Transpose(sData)
End Sub


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

هناك 3 تعليقات:

  1. اخى الفاضل ما شاء الله عليك

    ردحذف
  2. بارك الله فيك أخي الغالي جلال الجمال وجزيت خيراً على مرورك الندي بالمدونة

    ردحذف
  3. .انضم إلى eToro وقُد ثورة التكنولوجيا المالية

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

    ردحذف