السلام عليكم ورحمة الله
أخي الكريم، أرسل لك الملف مرة أخرى على أمل أن يفتح معك دون مشاكل... وأرسل لك الكود الذي عدلته :
Sub فحص()
With Sheets("رئيسي")
.Range("J1:J10000").ClearContents
On Error Resume Next
Set ww = Application.WorksheetFunction
LastRow = .Cells(Rows.Count, "G").End(xlUp).Row
Application.ScreenUpdating = False
.Range(.Cells(1,10), .Cells(1000, 10)).ClearContents
For R = 2 To LastRow
If ww.CountIf(.Range("G1:G"& R), .Cells(R, 7).Value) > 1 Then
.Cells(10,10).End(xlUp).Offset(1, 0) = .Cells(R,7)
End If
Next
.Range("G1:O1000").Sort .[b5], xlAscending
For N = 2 To LastRow
If .Cells(N, 2) <> "" Then
.Cells(N, 1) = .Cells(N, 2).Row - 5
End If
Next
Application.ScreenUpdating = True
.Cells(2, 10).Select
On Error GoTo 0
.Range("J1:J3000").Sort Key1:=.Range("J1:J3000"), Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
End With
End Sub
أخوك بن علية
الملف المرفق : مفتاح جلب المكرر.rar