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

الاثنين، 25 أبريل 2016

مقارنة عمودين واستخراج القيم الفريدة منهما Compare Two Columns And Extract Unique Items

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

إليكم كود يقوم بمقارنة القيم في عمودين ثم استخراج القيم الفريدة من العمودين ثم ترتيب النتائج تصاعدياً.


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

إليكم الكود الذي يؤدي الغرض ، ويوضع الكود في موديول عادي Standard Module :

Sub Uniques_In_Two_Lists()
    Dim Cel     As Range
    Dim Rng1    As Range
    Dim Rng2    As Range

    Set Rng1 = Range("A2:A" & Cells(Rows.Count, "A").End(xlUp).Row)
    Set Rng2 = Range("D2:D" & Cells(Rows.Count, "D").End(xlUp).Row)

    Application.ScreenUpdating = False
        Range("B2:C1000").ClearContents
        Range("A1").CurrentRegion.Offset(1).Interior.Color = xlNone
        
        For Each Cel In Rng1
            If WorksheetFunction.CountIf(Rng2, Cel) = 0 Then
                Cel.Interior.Color = rgbSilver
                Range("B" & Rows.Count).End(xlUp).Offset(1) = Cel
            End If
        Next Cel
    
        For Each Cel In Rng2
            If WorksheetFunction.CountIf(Rng1, Cel) = 0 Then
                Cel.Interior.Color = rgbOlive
                Range("C" & Rows.Count).End(xlUp).Offset(1) = Cel
            End If
        Next Cel
    
        Range("B2:B" & Cells(Rows.Count, "B").End(xlUp).Row).Sort Key1:=Range("B2"), Order1:=xlAscending
        Range("C2:C" & Cells(Rows.Count, "C").End(xlUp).Row).Sort Key1:=Range("C2"), Order1:=xlAscending
    Application.ScreenUpdating = True
End Sub

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

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

  1. السلام عليكم ... كود رائع جداً ...بارك الله

    ردحذف
  2. وعليكم السلام ..الأروع هو مرروك العطر بالموضوع ..جزيت خيراً أبا يوسف

    ردحذف
  3. هذا ما كنت ابحث عنه

    كود بطل من استاذ بطل

    ردحذف
  4. الحمد لله أن وجدت ضالتك أخي الكريم علي ..قل الحمد لله

    ردحذف
  5. الحمد لله على جميع نعمه نا نعلمه منها وما لا نعلمه
    جزاك الله عنا كل خير

    ردحذف
  6. وجزيت خيراً أخي الفاضل بمثل ما دعوت لي وزيادة

    ردحذف
  7. طول عمرك برنس ومبدع ... أحمد شمس

    ردحذف
  8. منور المدونة يا كبير .. بارك الله فيك وجزاك الله خيراً

    ردحذف
  9. وجزيت خيراً بمثل ما دعوت لي أخي العزيز عبد الرحمن

    ردحذف