تحديد الصفّوف المكررة ( تابع)

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

تم التعديل قليلاً على الموضوع السابق 

لادراج الصفوف المكررة وليس فقط تحديدها

Find_dup_rows_NEW.xlsm

[مداد_1423]

رائع يا كبير 

الكود مفيد جدا للكثير

بارك الله فيك وكثر من أمثالك

عبقرية من عبقري

عندي اقتراح ممكن يضيف للمستخدمين

لو في قائمة المكررات يكون في ترقيم لعدد التكرار أتوقع بيرتقي بالفائدة من الملف كثيرا

مثلاً

تم تعديل مارس 7, 2020 بواسطه مداد_1423

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

ممكن ذلك من خلال هذا التعديل على الكود

Option Explicit

Sub Find_Dupl_Rows_new()
    Dim I%, Ro, m%
    Dim REP As Range, My_Rg As Range
    Dim COl As Collection
    Dim Arr, n
  Set COl = New Collection
  Set My_Rg = Range("A1").CurrentRegion
   Ro = My_Rg.Rows.Count
  Set My_Rg = My_Rg.Offset(1).Resize(Ro - 1)
 
 My_Rg.Interior.ColorIndex = xlNone
 Range("E2").Resize(Ro - 1).ClearContents
 Range("G2:K2").Resize(Ro - 1).Clear
For I = 2 To Ro
  Arr = Application.Transpose(Application.Transpose _
  ((Cells(I, 2).Resize(, 3))))
  Arr = Join(Arr, "*")
  On Error Resume Next
  COl.Add I, Arr
  If Err.Number <> 0 Then
    m = m + 1
        Cells(I, 5) = "Duplicate"
        Cells(I, 5).Interior.ColorIndex = 40
      If REP Is Nothing Then
        Set REP = Cells(I, 2).Resize(, 3)
      Else
        Set REP = Union(REP, Cells(I, 2).Resize(, 3))
      End If 'REP
  End If 'Err
Next I
On Error GoTo 0
If Not REP Is Nothing Then
    REP.Interior.ColorIndex = 40
    MsgBox "You have :" & m & " duplicate Rows"
    n = REP.Areas.Count
    m = 1
    For I = 1 To n
      Range("G1").Offset(m).Resize(REP.Areas(I). _
      Rows.Count, 3).Value = REP.Areas(I).Value
      Range("j1").Offset(m) = REP.Areas(I).Address
      Range("K1").Offset(m) = REP.Areas(I).Rows.Count
      m = m + REP.Areas(I).Rows.Count
    Next
    '=================================
     With Cells(2, "g").Resize(m - 1, 5)
     .Borders.LineStyle = 1: .Font.Size = 16
     .Font.Bold = True: .Interior.ColorIndex = 28
     .InsertIndent 1
     End With
    
    '=========================
  Else
   MsgBox "Not duplicate Rows "
End If
Set COl = Nothing: Set REP = Nothing
End Sub

 

[Ali Mohamed Ali]

أحسنت استاذ سليم بارك الله فيك وزادك الله من فضله

[MAHMOUD ALI YOUSSEF]

  احسنت يا استاذ سليم حاصبيا