مقارنة متقدمة

[محسن33]

السلام عليكم لدي عمودين في حدود 200000 صف

اريد مقارنة العمودين واستخراج القيم المختلفة بينهم بالرغم من تكرارها في العمود الاخر

مرفق

لا داعى لضغط الملف طالما مساحته صغيره

 

مقارنة.xlsx

[حسونة حسين]

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

تفضل

مقارنة.xlsb

[عبدالله بشير عبدالله]

حل رائع معلمنا  حسونة حسين

تم تعديل سبتمبر 23 بواسطه عبدالله بشير عبدالله

[عمر الجزاوى]

استاذ حسونة حل رائع بعد اذنك ممكن تضيف لينا شرط ثالث ان الكود يظهر القيم المشتركة بين العمودين

[حسونة حسين]

تفضل اخى 

 

مقارنة.xlsb

[عمر الجزاوى]

استاذ حسونة الف شكرا  على الاهتمام انا كنت ببحث عن حل قريب ووجدت خلول بالدوال ولكن حلك بالكود رائع وجميل ومميز الف الف شكر

[حسونة حسين]

الشكر لله اخى

والحمد لله الذي وفقنا لمساعدتك

[محسن33]

السلام عليكم

شكرا على الحل للاخ العزيز حسونة حسين

ولكن جربت ادخل بيانات حتى الصف20000 وعند الضغط على الcommandbutton ظهر error

 

 

تم تعديل سبتمبر 24 بواسطه محسن33

[محمد هشام.]

اظن ان الكود المقترح من الاستاد @حسونة حسين   يشتغل بشكل جيد على العموم جرب هدا 

Option Explicit
Sub test()
    Dim arr As Variant, i As Long, Irow As Long
    Dim tmp1 As Object, tmp2 As Object, c As Variant
    Dim n As Variant, a As Variant, b As Variant
    Dim WS As Worksheet: Set WS = Sheets("Sheet1")
    
    Application.ScreenUpdating = False
    
    With WS
    Irow = .Columns("A:E").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
        If Irow > 1 Then
            .Range("C2:E" & Irow).ClearContents
        End If
        
        arr = .Range("A2:B" & Irow).Value
        Set tmp1 = CreateObject("Scripting.Dictionary")
        Set tmp2 = CreateObject("Scripting.Dictionary")
        
        For i = 1 To UBound(arr, 1)
            If arr(i, 1) <> "" Then tmp1(arr(i, 1)) = True
            If arr(i, 2) <> "" Then tmp2(arr(i, 2)) = True
        Next i
        
        For Each n In tmp1
            If tmp2.exists(n) Then
                c = cnt(c, n)
                tmp2.Remove n
            Else
                a = cnt(a, n)
            End If
        Next n
        
        For Each n In tmp2
            b = cnt(b, n)
        Next n
        
        If Not IsEmpty(a) Then [C2].Resize(UBound(a), 1).Value = WorksheetFunction.Transpose(a)
        If Not IsEmpty(b) Then [D2].Resize(UBound(b), 1).Value = WorksheetFunction.Transpose(b)
        If Not IsEmpty(c) Then [E2].Resize(UBound(c), 1).Value = WorksheetFunction.Transpose(c)
        
        Application.ScreenUpdating = True
    End With
End Sub
Function cnt(arr As Variant, Value As Variant) As Variant
    If IsEmpty(arr) Then
        ReDim arr(1 To 1)
        arr(1) = Value
    Else
        ReDim Preserve arr(1 To UBound(arr) + 1)
        arr(UBound(arr)) = Value
    End If
    cnt = arr
End Function

 

 

 

مقارنة 3.xlsb

تم تعديل سبتمبر 24 بواسطه محمد هشام.

[حسونة حسين]

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

في 24‏/9‏/2024 at 03:28, محسن33 said:

ولكن جربت ادخل بيانات حتى الصف20000 وعند الضغط على الcommandbutton ظهر error

ما هو الخطأ الذي يظهر لانه لا يظهر اخطأء بعد وضع بيانات الي الصف ٢٠ ألف

[محسن33]

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

هل يمكن الارقام الموجودة في الاعمدة C و D

تظليل بلون اصفر   في العمود  A و العمود B بلون  برتقالي

 

 

 

تم تعديل أكتوبر 31 بواسطه محسن33

[محسن33]

للرفع

[محمد هشام.]

Option Explicit
Sub test()
    Dim arr As Variant, i As Long, Irow As Long
    Dim dictA As Object, dictB As Object, dictC As Object, dictD As Object
    Dim n As Variant, a As Variant, b As Variant, c As Variant
    Dim WS As Worksheet: Set WS = Sheets("Sheet1")

    With WS
     Irow = .Columns("A:E").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
        If WorksheetFunction.CountA(.Range("A2:A" & Irow)) = 0 And _
        WorksheetFunction.CountA(.Range("B2:B" & Irow)) = 0 Then
            MsgBox "لا توجد بيانات للمقارنة", vbExclamation
            Exit Sub
        End If
'Code .............
..................

Set dictC = CreateObject("Scripting.Dictionary")
    Set dictD = CreateObject("Scripting.Dictionary")
    For i = 2 To Irow
        If WS.Cells(i, 3).Value <> "" Then dictC(WS.Cells(i, 3).Value) = True
        If WS.Cells(i, 4).Value <> "" Then dictD(WS.Cells(i, 4).Value) = True
    Next i
    
    For i = 2 To Irow
        If WS.Cells(i, 1).Value <> "" Then
            If dictC.exists(WS.Cells(i, 1).Value) Or dictD.exists(WS.Cells(i, 1).Value) Then
                WS.Cells(i, 1).Interior.Color = RGB(255, 255, 0)
            End If
        End If
        
        If WS.Cells(i, 2).Value <> "" Then
            If dictC.exists(WS.Cells(i, 2).Value) Or dictD.exists(WS.Cells(i, 2).Value) Then
                WS.Cells(i, 2).Interior.Color = RGB(255, 165, 0)
            End If
        End If
    Next i
    
    Application.ScreenUpdating = True
End Sub

 

مقارنة 3.xlsb

[mahmoud nasr alhasany]

احسنت أ / حسونة حسين 

احسنت أ / محمد هشام

على المجهود الرائع الذى بزلتموه 

تم تعديل نوفمبر 1 بواسطه mahmoud nasr alhasany