حذف الأرقام المكررة

[مصطفى شاهين]

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

لديّ ملف به أرقام جهات اتصال تقريباً 3000 رقم، يوجد أرقام مكررة، أريد حذف الأرقام المكررة، وعدم إبقاء أين منهما.

هل يمكن ذلك؟

[محمد هشام.]

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

سؤال غير واضح  يجب دكر مكان تواجد  البيانات المكررة هل عمود معين مثلا  او نطاق او مادا .......

[مصطفى شاهين]

12 ساعات مضت, محمد هشام. said:

سؤال غير واضح  يجب دكر مكان تواجد  البيانات المكررة هل عمود معين مثلا  او نطاق او مادا .......

تكرار البيانات في عمود

[أ / محمد صالح]

سهلة بإذن الله

حدد العمود المراد
تبويب “البيانات” (Data).
اختر “إزالة التكرارات” (Remove Duplicates).

بالتوفيق

[محمد هشام.]

لحدفها يدويا اقتراح الاستاد @أ / محمد صالح سيوفي بالغرض أما ادا كانت لديك نية في استخدام الأكواد اليك بعض الحلول يمكنك تعديلها بما يناسبك 

لنفترض ان القيم المكررة موجودة في عمود (A)  مثلا

لحدف جميع التكرارات يمكنك استخدام هدا 

Sub Supprimer_doublons()
' حدف التكرارات بدون التأثير على الأعمدة المجاورة
  Application.ScreenUpdating = False
  Application.Calculation = xlCalculationManual
  Dim f As Worksheet: Set f = ThisWorkbook.Sheets("Sheet1")
  Set Col = f.Range("A2:A" & f.[A65000].End(xlUp).Row)
  For i = f.[A65000].End(xlUp).Row To 2 Step -1
    If Application.CountIf(Col, f.Cells(i, 1)) > 1 Then
        f.Cells(i, 1).Delete Shift:=xlUp
    End If
  Next i
  Application.Calculation = xlAutomatic
End Sub
'*****************************
Sub Supprimer_les_doublons()
    ' حدف الصف بالكامل
    Dim Irow As Long, dict As Object
    Dim i As Long, tmp As Variant
    
   'قم بتحديد إسم العمود بما يناسبك
    Dim Col As String: Col = "A"
   ' قم بتحديد صف البداية
    Dim startRow As Long: startRow = 1
    
    Dim f As Worksheet: Set f = ThisWorkbook.Sheets("Sheet1")
        
        Irow = f.Cells(f.Rows.Count, "A").End(xlUp).Row
        Set dict = CreateObject("Scripting.Dictionary")
        
        For i = startRow To Irow
        tmp = f.Cells(i, Col).Value
        If tmp <> "" Then
            If dict.exists(tmp) Then
               f.Rows(i).Delete
                i = i - 1
                Irow = Irow - 1
                n = n + 1
            Else
                dict.Add tmp, True
            End If
        End If
    Next i
    If n = 0 Then
        MsgBox "لم يتم العثور على أي تكرارات ", vbInformation
    Exit Sub
    Else
        MsgBox "تم حذف " & n & " من التكرارات", vbInformation
End If
End Sub

وهدا  في حالة الرغبة لتحديد الحد الأقصى للتكرارات على العمود 

Sub Supprimer_les_doublons_sélectionnés()
    Dim f As Worksheet, n As Long
    Dim Irow As Long, i As Long
    Dim dict As Object, tmp As Variant
    
    Set f = ThisWorkbook.Sheets("Sheet1")
    Irow = f.Cells(f.Rows.Count, "A").End(xlUp).Row
    
    ' تحديد اسم العمود
    Dim Col As String: Col = "A"
    
    ' تحديد صف البداية
    Dim startRow As Long: startRow = 1
    
    'عدد التكرارات
    Dim cnt As Long: cnt = 2  '<====  ' قم بتعديل عدد التكرارات المسموح بها بما يناسبك

    Set dict = CreateObject("Scripting.Dictionary")
    n = 0
        For i = Irow To startRow Step -1
        tmp = f.Cells(i, Col).Value
        If tmp <> "" Then
            If dict.exists(tmp) Then
                dict(tmp) = dict(tmp) + 1
            Else
                dict.Add tmp, 1
            End If
            If dict(tmp) > cnt Then
              f.Rows(i).Delete
                n = n + 1
            End If
        End If
    Next i
    If n = 0 Then
        MsgBox "لم يتم العثور على أي تكرارات تتجاوز العدد المسموح به", vbInformation
    Else
        MsgBox "تم حذف " & n & " من التكرارات الزائدة", vbInformation
    End If
End Sub

 

Supprimer_les_doublon.xlsb

[مصطفى شاهين]

في 3‏/9‏/2024 at 12:40, أ / محمد صالح said:

اختر “إزالة التكرارات” (Remove Duplicates).

 

كلام سليم، وفي حالة رغبتي في إزالة كل التكرارات، لنفترض أن رقم 1 مكرر 10 مرات، سيحذف 9 مرات المكررة ويُبقي على رقم 1، حتى الرقم الأخير أريد حذفه، يحذف جميع التكرارات بما فيهم نفس الرقم المكرر

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

15 ساعات مضت, محمد هشام. said:

لحدف جميع التكرارات يمكنك استخدام هدا 

هل الكود ينطبق على ملاحظتي أعلاه.

أشكر لكم جهودكم الطيبة

[محمد هشام.]

 هذا الكود سيحذف جميع الصفوف التي تحتوي على قيم غير فريدة في العمود المحدد

بمعنى سيتم حذف جميع الصفوف التي تحتوي على قيم متكررة، بما في ذلك النسخة الأولى لكل قيمة

Sub RemoveAllDuplicates()
    Dim f As Worksheet
    Dim Irow As Long, i As Long
    Dim dict As Object, tmp As Variant
    Dim uniqueDict As Object
    Dim n As Long
    
    Dim Col As String: Col = "A"
    Dim startRow As Long: startRow = 2
    
    Set f = ThisWorkbook.Sheets("Sheet1")
    Irow = f.Cells(f.Rows.Count, Col).End(xlUp).Row
    
    Set dict = CreateObject("Scripting.Dictionary")
    Set uniqueDict = CreateObject("Scripting.Dictionary")
    n = 0
        For i = startRow To Irow
        tmp = f.Cells(i, Col).Value
        
        If tmp <> "" Then
            If dict.exists(tmp) Then
                dict(tmp) = dict(tmp) + 1
            Else
                dict.Add tmp, 1
            End If
        End If
    Next i
        For i = Irow To startRow Step -1
        tmp = f.Cells(i, Col).Value
        
        If tmp <> "" Then
            If dict(tmp) > 1 Then
                f.Rows(i).Delete
                n = n + 1
            ElseIf dict(tmp) = 1 And uniqueDict.exists(tmp) Then
                f.Rows(i).Delete
                n = n + 1
            Else
                uniqueDict.Add tmp, True
            End If
        End If
    Next i
        If n > 0 Then
        MsgBox "تم حذف جميع التكرارات" & vbCrLf & _
        vbCrLf & "عدد الصفوف المحذوفة: " & n, vbInformation
    Else
        MsgBox "لم يتم العثور على أي تكرارات", vbInformation
    End If
End Sub

 

 

Supprimer_les_doublon.xlsb

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

[مصطفى شاهين]

23 ساعات مضت, محمد هشام. said:

 هذا الكود سيحذف جميع الصفوف التي تحتوي على قيم غير فريدة في العمود المحدد

بمعنى سيتم حذف جميع الصفوف التي تحتوي على قيم متكررة، بما في ذلك النسخة الأولى لكل قيمة

بارك الله فيك، هذا هو المطلوب تماماً

أسأل الله العظيم رب العرش الكريم أن ييسر أمركم، ويجعل هذا العمل في ميزان حسناتكم إلى يوم الدين

بوركت الجهود الطيبة لكم، ولكل من ساهم ويساهم في هذا الصرح العظيم

دمتم بخير