تغيير مدى البحث فى محرر الاكواد VBA

[edkawy]

الاخوه الكرام 

 

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

 

برجاء تعديل الكود الموجود بالملف المرفق ( وجدته على الانترنت )

المدى الموجود بالكود حتى الصف رقم اربعين فقط و ارجو التعديل فى عدد الصفوف حتى الصف رقم اربعين الف لأن كميه الداتا الموجوده فى الملف كبيره جدا

 

ولكم جزيل الشكر 

 

 

Compare-2-Columns-Show-differences-Through-VBA.zip

[أبو حنــــين]

السلام عليكم

يصبح الكود هكذا

Sub PullUniques()
Application.ScreenUpdating = False
Dim rngCell As Range
For Each rngCell In Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row)
    If WorksheetFunction.CountIf(Range("B2:B" & Cells(Rows.Count, 2).End(xlUp).Row), rngCell) = 0 Then
        Range("C" & Rows.Count).End(xlUp).Offset(1) = rngCell
    End If
Next
For Each rngCell In Range("B2:B" & Cells(Rows.Count, 2).End(xlUp).Row)
    If WorksheetFunction.CountIf(Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row), rngCell) = 0 Then
        Range("D" & Rows.Count).End(xlUp).Offset(1) = rngCell
    End If
Next
Application.ScreenUpdating = True
End Sub

 

[سليم حاصبيا]

بعد اذن اخي ابو حنين 

هذا الكود(ربما اسره قليلاُ) حيث انه يخرج من الـ Loop  فور حصوله على نتيجة

Sub transfer()
Dim i As Long, tr As Boolean, x, y As Integer
Dim lra, lrb, lr As Long
    lrb = Cells(Rows.Count, 2).End(3).Row
    lra = Cells(Rows.Count, 1).End(3).Row
    lr = Application.Max(lrb, lra)

Range("c2:d" & lr).ClearContents
i = 2
 Do Until Range("a" & i) = ""
        tr = False
        x = Application.CountIf(Range("a2:a" & i), Range("a" & i))
        y = Application.CountIf(Range("b2:b" & lrb), Range("a" & i))
            If x = 1 And y = 0 Then
              tr = True: GoTo 1
            End If
1:
            If tr = True Then
                Cells(m + 2, 3) = Range("a" & i)
                m = m + 1
            End If
         i = i + 1
  Loop
  '======================================
  m = 0
  i = 2
 Do Until Range("b" & i) = ""
        tr = False
        x = Application.CountIf(Range("b2:b" & i), Range("b" & i))
        y = Application.CountIf(Range("a2:a" & lra), Range("b" & i))
            If x = 1 And y = 0 Then
                tr = True: GoTo 2
            End If
2:
            If tr = True Then
                Cells(m + 2, 4) = Range("b" & i)
                m = m + 1
            End If
         i = i + 1
Loop
End Sub
    

 

[ابو عبدالبارى]

3 ساعات مضت, edkawy said:

الاخوه الكرام 

 

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

 

برجاء تعديل الكود الموجود بالملف المرفق ( وجدته على الانترنت )

المدى الموجود بالكود حتى الصف رقم اربعين فقط و ارجو التعديل فى عدد الصفوف حتى الصف رقم اربعين الف لأن كميه الداتا الموجوده فى الملف كبيره جدا

 

ولكم جزيل الشكر 

 

 

Compare-2-Columns-Show-differences-Through-VBA.zip

الأخ الكريم edkawy

السلام عليكم وبعد اذن الأخوة الأعزاء ربما يفيد هذا الكود

Sub abo_abary()
last1 = Cells(Rows.Count, "a").End(xlUp).Row
last2 = Cells(Rows.Count, "b").End(xlUp).Row
y = 2
For x = 2 To last1
If Application.CountIf(Range("b2:b" & last1), Range("a" & x)) = 0 Then Range("c" & y) = Range("a" & x): y = y + 1
Next
y = 2
For x = 2 To last2
If Application.CountIf(Range("a2:a" & last2), Range("b" & x)) = 0 Then Range("d" & y) = Range("b" & x): y = y + 1
Next

End Sub

 

[الـعيدروس]

السلام عليكم

الى حلول الاخوه الاحبه لاثراء الموضوع تفضل الكود التالي

 

Sub Cmpre_Ali()
Dim List_a, Ar(), Cnt&, R&
'-------
List_a = Range("a2").CurrentRegion.Resize(, 2).Offset(1).Value
'-------
With CreateObject("Scripting.Dictionary")
    .CompareMode = vbTextCompare
    For R = 1 To UBound(List_a, 1)
        If (Not IsEmpty(List_a(R, 1))) * (Not .exists(List_a(R, 1))) Then .Add List_a(R, 1), Nothing
    Next
    ReDim Ar(1 To UBound(List_a, 1), 1 To 1)
    For R = 1 To UBound(List_a, 1)
        If Not IsEmpty(List_a(R, 2)) Then
            If Not .exists(List_a(R, 2)) Then
                Cnt = Cnt + 1: Ar(Cnt, 1) = List_a(R, 2)
            Else
                .Remove List_a(R, 2)
            End If
        End If
    Next
    If Cnt > 0 Then Range("C1").Offset(1, 1).Resize(Cnt).Value = Ar
    If .Count > 0 Then Range("C1").Offset(1).Resize(.Count).Value = Application.Transpose(.keys)
    Erase Ar
End With
End Sub

تحياتي

[edkawy]

الاساتذه الكرام :

أبو حنين 

سليم حاصبيا

أبو عبد البارى 

العيدروس 

 

حلول اكتر من ممتازه و جزاكم الله خير . الملف اشتغل معايا زى ما انا عاوز بالظبط 

 

بارك الله فيكم جميعا 

 

السلام عليكم