Sub فحص()
On Error Resume Next
Set ww = Application.WorksheetFunction
LastRow = Cells(Rows.Count, "B").End(xlUp).Row
Application.ScreenUpdating = False
Range("A6:A" & LastRow).ClearContents
Range(Cells(6, 10), Cells(1000, 10)).ClearContents
For R = 6 To LastRow
If ww.CountIf(Range("B6:B" & R), Cells(R, 2).Value) > 1 Then
Cells(1000, 10).End(xlUp).Offset(1, 0) = Cells(R, 2)
Range(Cells(R, 2), Cells(R, 15)).ClearContents
End If
Next
Range("B6:O1000").Sort [B5], xlAscending
For N = 6 To LastRow
If Cells(N, 2) <> "" Then
Cells(N, 1) = Cells(N, 2).Row - 5
End If
Next
Application.ScreenUpdating = True
Cells(6, 10).Select
On Error GoTo 0
End Sub
أخى الفاضل هذا الكود للزميل الفاضل هشام شلبى
عدل فيه بما يتناسب مع عملك حيث الأسماء فى العمود B