السلام عليكم ورحمة الله و بركاته
بعد إذن الأخ الفاضل الاستاذ الكبير / يحيى حسين
الاخ / Abu Al Nour
تفضل هذا المرفق و ارجو من الله أن يتضح لك الحل من خلاله
فقط قم بالضغط على زرار جلب المكرر لترى ماذا يحدث
و الكود المستخدم هو :
Sub Button1_Click()
On Error Resume Next
Set ww = Application.WorksheetFunction
LastRow = Cells(Rows.Count, "B").End(xlUp).Row
Application.ScreenUpdating = False
Range("A2:A" & LastRow).ClearContents
Range(Cells(2, 5), Cells(1000, 5)).ClearContents
For R = 2 To LastRow
If ww.CountIf(Range("B2:B" & R), Cells(R, 2).Value) > 1 Then
Cells(1000, 5).End(xlUp).Offset(1, 0) = Cells(R, 2)
Range(Cells(R, 2), Cells(R, 2)).ClearContents
End If
Next
Range("B2:O1000").Sort [B2], xlAscending
For N = 2 To LastRow
If Cells(N, 2) <> "" Then
Cells(N, 1) = Cells(N, 2).Row - 2
End If
Next
Application.ScreenUpdating = True
Cells(2, 5).Select
On Error GoTo 0
End Sub
و ستجد هذاالكود في Module1
و يوجد شرح مبسط داخل الملف
و الله الموفق والمستعان
و السلام عليكم ورحمة الله و بركاته
جلب المكرر HaNcOcK 2.rar