حذف اسطر الاسماء المتكررة بالكامل

[أنس دروبي]

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

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

يقوم الكود بحذف الاسماء المتكررة 

ولكن يحذف المحتويات فقط وليس الاسطر المتكررة بالكامل 

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

ويقوم بحذف الاسطر المتكررة لهذه الاسم المتكرر وليس المحتويات فقط

ارجو ان تكون وضحت الفكرة

حذف المكرر.rar

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

جرب التعديل البسيط

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)).EntireRow.Delete
        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

 

[أنس دروبي]

أخي وأستاذي ياسر جزاك الله كل خير 

عرفت أين وجد التعديل وشكراً

ولكن تم تنفيذ الطلب الاول فقط 

الطلب الثاني كما ذكرته في المشاركة حذف الاسم المكرر بناء على خلية معينة موجود فيها الاسم الذي نريد حذفه

شاهد الملف المرفق

فيه الشرح بالتفصيل

حذف المكرر بناء على خلية معينة.zip

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

جرب الكود بهذا الشكل

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 = LastRow To 6 Step -1
        If Cells(R, 2).Value = Range("H2").Value Then
            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)).EntireRow.Delete
            End If
        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

 

[أنس دروبي]

ماشاء الله تبارك الله على هذا الابداع المتميز من صاحب فن وذوق رفيع

هذا هو المطلوب أخي ياسر مئة بالمئة 

بارك الله فيك وجزاك الله كل خير

وشكرأ