الرقم القومي المكرر

[ابوصلاح]

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

بعد اذن الاخوة الافاضل في المرفق ارقام قوميه

بها بعض الارقام المكرر اريد رسالة تنبيه بان الرقم القومي مكرر

او تنسيق شرطي للخلايا المكرر بلون معين يفيد بان الرقم القومي مكرر

الرقم القومي مكرر.rar

[ابوصلاح]

تم التوصل للمطلوب من خلال التنسيق الشرطي

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

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

الأخ الكريم  ابوصلاح

السلام عليكم

جرب الملف التالى بالمعادلات لعلة يفى بالغرض

 

abo_abary_الرقم القومي مكرر.zip

[أبو سجده]

الاخ الكريم الاستاذ // صلاح

السلام عليكم

وماذا لو هناك أكثر من رقم مكرر 

ارى أن رسالة التنبيه هنا لا تجدى نفعا

الا إذا أردت ترحيل الارقام المكررة بشيت منفصل

هذا والله أعلى وأعلم بطبيعة عملك

جرب هذا الكود وبحول الله تعالى نتيجته 100%

Sub duplicate()
Dim arr As Variant, d As Object, rng As Range, I As Long
Set d = CreateObject("scripting.dictionary")
arr = Range("F1:F" & Cells(Rows.Count, "F").End(3).Row)
For I = 1 To UBound(arr)
    If Len(arr(I, 1)) > 0 Then
        d(arr(I, 1)) = d(arr(I, 1)) + 1
        If d(arr(I, 1)) > 1 Then
            If rng Is Nothing Then
                Set rng = Cells(I, "F")
            Else
                Set rng = Union(rng, Cells(I, "F"))
            End If
        End If
    End If
Next
rng.Interior.Color = vbYellow
Set d = Nothing
End Sub

 

[أبو سجده]

15 دقائق مضت, ابو عبدالرحمن بيرم said:

الا إذا أردت ترحيل الارقام المكررة بشيت منفصل

 

أو حذف الارقام المكررة بذات الشيت

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

[أبو سجده]

الاخ الفاضل الاستاذ // صلاح

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

ضع قائمة الارقام لديك بالعمود A  بداية من الصف الثامن وشاهد النتيجة

Sub Duplicate2()
  Dim coll As New Collection, rng As Range, rngDelete As Range, arr, C As Long, I As Long, strKey As String, v1
  Set rng = Range("A8").CurrentRegion
  rng.Offset(1).Interior.ColorIndex = xlNone
  arr = rng.Value
  For I = 2 To UBound(arr, 1)
      strKey = arr(I, 1) & Chr$(2)
      On Error Resume Next
         coll.Add Key:=strKey, Item:=New Collection
      On Error GoTo 0
      coll(strKey).Add I
  Next I
  For Each v1 In coll
      If v1.Count > 1 Then
         C = RGB(Int(Rnd * 256), Int(Rnd * 256), Int(Rnd * 256))
         For I = 1 To v1.Count
             rng.Rows(v1(I)).Interior.Color = C
             If I > 1 Then
                If rngDelete Is Nothing Then Set rngDelete = rng.Rows(v1(I)) Else Set rngDelete = Union(rngDelete, rng.Rows(v1(I)))
             End If
         Next I
      End If
  Next v1
  If Not rngDelete Is Nothing Then
     If MsgBox("هل ترغب فى حذف الارقام القومية المكررة ?", vbYesNo) = vbYes Then rngDelete.Delete xlShiftUp
  End If
End Sub

 

[أبو سجده]

المرفق به التطبيق

 

Delete duplicate items.rar

[ياسر خليل أبو البراء]

بسم الله ما شاء الله أخي وحبيي أبو عبد الرحمن ..

ملف رائع من شخص مميز .. 

[ابوصلاح]

    ^{الافاضل :-}

                    ^{الاستاذ ابو عبد الباري}

                          ^{الاستاذ ابو عبد الرحمن}

                          ^{حلول رائعة باركالله فيكم}

^{الاستاذ ياسر خليل ما من مرفق  الا ونجده حاضرا(يقدم حل او معلقا او مرشدا ) بارك الله فيك}