فرز وحذف المكرر في قاعدة بيانات كبيرة

[محمد الزريعي]

المطلوب هو كيف يتم حذف الأرقم في الورقة 1 أذا كان هذا الرقم موجود في الورقة 2

وأضافه أي رقم الي الورقة 2 من الورقة 1 أذا كان غير موجود

___

طبعاً سويت هذا على الكود ولكن كان عندي بطئ جداً ..

علماً بأن الأرقام في كل ورقة ما يقارب 120 ألف رقم .

نرجو التكرم منكم بالمساعدة أذا أمكن شاكرين ومقدرين حسن تعاونكم معنا

فزر المكرر.rar

[محمد السراي]

أخي الكريم لدي نفس الحالة ولكن ليست ارقام بل اسماء ولأ أعرف تحديد المكرر اكسل 2003 عربي

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

السلام عليكم 

 

جرب الكود التالي

Sub kh_Start()

Dim Rng1 As Range, Rng2 As Range
Dim Cel As Range, CelDelete As Range

With Sheets("1")
    Set Rng1 = .Range("B3", .Range("B" & Rows.Count).End(xlUp))
End With

With Sheets("2")
    Set Rng2 = .Range("B4", .Range("B" & Rows.Count).End(xlUp))
End With

For Each Cel In Rng1
    If WorksheetFunction.CountIf(Rng2, Cel) Then
        If CelDelete Is Nothing Then Set CelDelete = Cel Else Set CelDelete = Union(CelDelete, Cel)
    Else
        With Sheets("2")
            If Len(.Range("C4")) Then .Range("C4").Insert Shift:=xlDown
            .Range("C4").Value = Cel.Value
        End With
    End If
Next

If Not CelDelete Is Nothing Then CelDelete.EntireRow.Delete

Set Rng1 = Nothing
Set Rng2 = Nothing
Set CelDelete = Nothing
End Sub

المرفق 2010

فزر المكرر.rar

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

السلام عليكم

 

جرب هذا ايضا اظنه اسرع من السابق

Sub kh_Start()

Dim Rng1 As Range, Rng2 As Range
Dim Cel As Range, CelDelete As Range

With Sheets("1")
    Set Rng1 = .Range("B3", .Range("B" & Rows.Count).End(xlUp))
End With

With Sheets("2")
    Set Rng2 = .Range("B3", .Range("B" & Rows.Count).End(xlUp))
End With

For Each Cel In Rng1
    If WorksheetFunction.CountIf(Rng2, Cel) Then
        If CelDelete Is Nothing Then Set CelDelete = Cel Else Set CelDelete = Union(CelDelete, Cel)
    Else
        Sheets("2").Range("C" & Rows.Count).End(xlUp).Offset(1, 0).Value = Cel.Value
    End If
Next

If Not CelDelete Is Nothing Then CelDelete.EntireRow.Delete

Set Rng1 = Nothing
Set Rng2 = Nothing
Set CelDelete = Nothing
End Sub

المرفق 2010

فزر المكرر.rar

[محمد الزريعي]

سويت الكود ونفس  الشيء .. مازال بطئ .. لحد الأن مضت 10 دقائق ولم يحدث أي نتيجة .

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

السلام عليكم

 

جرب هذا فقد جربته على اكثر من 120000 صف

Sub kh_Start()
Dim Obj As Object
Dim tx As String
Dim Rng1 As Range, Rng2 As Range
Dim Cel As Range, CelDelete As Range, CelValue As Range

On Error GoTo 1
'''''''''''''''''''''''''''''
With Sheets("1")
    Set Rng1 = .Range("B3", .Range("B" & Rows.Count).End(xlUp))
End With
'''''''''''''''''''''''''''''
With Sheets("2")
    Set Rng2 = .Range("B3", .Range("B" & Rows.Count).End(xlUp))
End With
'''''''''''''''''''''''''''''
Set Obj = CreateObject("Scripting.Dictionary")
'''''''''''''''''''''''''''''
For Each Cel In Rng2
    tx = Trim(Cel)
    If Not Obj.Exists(tx) Then Obj.Add tx, 1
Next
'''''''''''''''''''''''''''''

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'''''''''''''''''''''''''''''
For Each Cel In Rng1
    If Obj.Exists(CStr(Cel)) Then
        If CelDelete Is Nothing Then Set CelDelete = Cel Else Set CelDelete = Union(CelDelete, Cel)
    Else
        If CelValue Is Nothing Then Set CelValue = Cel Else Set CelValue = Union(CelValue, Cel)
    End If
Next
'''''''''''''''''''''''''''''
If Not CelDelete Is Nothing Then CelDelete.EntireRow.Delete
If Not CelValue Is Nothing Then
    CelValue.Copy
    Sheets("2").Range("C" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
    Application.CutCopyMode = False
End If
'''''''''''''''''''''''''''''
1:
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
'''''''''''''''''''''''''''''
Set Rng1 = Nothing: Set Rng2 = Nothing: Set CelDelete = Nothing: Set CelValue = Nothing: Set Obj = Nothing
If Err Then MsgBox "Err.Number : " & Err.Number Else MsgBox "الحمد لله تمت التصفية بنجاح"
End Sub

جرب واشعرنا بالنتيجة

 

تحياتي

[الخالدي]

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

بارك الله فيك استاذ/ عبدالله باقشير

تقبل الله منا ومنكم صالح الاعمال 

ولإثراء الموضوع

الكود التالي يقوم بحذف المكرر

الكود يقوم  بفرز الارقام في الورقتين لغرض عدم تكرار فحص خلايا اي جدول اكثر من مرة

في امان الله

فزر المكرر بالفرز.rar

[ابوهيام]

اسعدكم الله في دنياكم وآخرتكم

 

هل يمكن تطبيق الكود على اسماء