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

إخواني وأحبابي في الله



أقدم لكم كود غاية في الروعة وهو كود مفيد جداً .. الكود سيقوم بعمل مقارنة بين عمودين ، ونتائج الكود ستكون بالتفصيل ، حيث يقوم الكود على سبيل المثال بمقارنة العمود الأول والعمود الثاني كما بالشكل التالي


ثم يقوم الكود باستخراج النتائج بهذا الشكل
--------------------------
** كل القيم الموجودة في العمودين بدون تكرار (في العمود الثالث)

** القيم الموجودة في القائمة الأولى وليس موجود في القائمة الثانية (في العمود الرابع)

** القيم الموجودة في القائمة الثانية وليس موجود في القائمة الأولى (في العمود الخامس)

** القيم الموجودة في كلا العمودين أي القيم المشتركة فقط (في العمود السادس)

ستكون النتائج بهذا الشكل


وأخيراً إليكم الكود المستخدم لتنفيذ عملية المقارنة بين القائميتن

Sub Compare_Two_Lists()
    Dim list1           As Variant
    Dim list2           As Variant
    Dim list3()         As String
    Dim list4()         As String
    Dim list5()         As String
    Dim arrBoth()       As String
    Dim size1           As Long
    Dim size2           As Long
    Dim pointer3        As Long
    Dim pointer4        As Long
    Dim pointer5        As Long
    Dim pointBoth       As Long
    Dim i               As Long
    
    Const iResult       As Long = 2
    
    With Range("A:A")
        list1 = Range(.Cells(2, 1), .Cells(Rows.Count, 1).End(xlUp)).Value
    End With
    With Range("B:B")
        list2 = Range(.Cells(2, 1), .Cells(Rows.Count, 1).End(xlUp)).Value
    End With
    size1 = UBound(list1, 1)
    size2 = UBound(list2, 1)

    ReDim list3(1 To size1 + size2, 1 To 1)
    ReDim list4(1 To size1, 1 To 1)
    ReDim list5(1 To size2, 1 To 1)
    ReDim arrBoth(1 To size1 + size2, 1 To 1)

    For i = 1 To size1
        pointer3 = pointer3 + 1
        list3(pointer3, 1) = list1(i, 1)

        If IsNumeric(Application.Match(list1(i, 1), list2, 0)) Then
            pointBoth = pointBoth + 1
            arrBoth(pointBoth, 1) = list1(i, 1)
        Else
            pointer4 = pointer4 + 1
            list4(pointer4, 1) = list1(i, 1)
        End If
    Next i

    For i = 1 To size2
        If IsError(Application.Match(list2(i, 1), list1, 0)) Then
            pointer3 = pointer3 + 1
            list3(pointer3, 1) = list2(i, 1)

            pointer5 = pointer5 + 1
            list5(pointer5, 1) = list2(i, 1)
        End If
    Next i

    Application.ScreenUpdating = False
        With Range("C:C").Resize(size1 + size2, 1).Offset(iResult - 1, 0)
            .Value = list3
            .Sort key1:=.Cells(1, 1), order1:=xlAscending, Header:=xlYes
        End With
    
        With Range("D:D").Resize(size1, 1).Offset(iResult - 1, 0)
            .Value = list4
            .Sort key1:=.Cells(1, 1), order1:=xlAscending, Header:=xlYes
        End With
    
        With Range("E:E").Resize(size2, 1).Offset(iResult - 1, 0)
            .Value = list5
            .Sort key1:=.Cells(1, 1), order1:=xlAscending, Header:=xlYes
        End With
    
        With Range("F:F").Resize(size1 + size2, 1).Offset(iResult - 1, 0)
            .Value = arrBoth
            .Sort key1:=.Cells(1, 1), order1:=xlAscending, Header:=xlYes
        End With
    Application.ScreenUpdating = True
End Sub

رابط الملف من هنا

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