حذف المكررات

[توكل]

هذا الكود أيها الأحبة طوره أحد الإخوة في المنتدى وعذراً فأنا لا أعرف صاحبه" جزاه الله عنا كل خير"

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

لكن هذا الكود لا يعمل إلى في العمود B فهل يمكن أن يتم تعديل الكود ليعمل إنطلاقاً من الخلية الفعالة مع جزيل الشكر والتقدير، وحفظ الحقوق للأخ الذي طور الكود أولاً جزاه الله مرة أخرى عنا كل خير

Sub dellduplicates()

Dim MyRng As Range

Set MyRng = Range("B3:B" & Cells(Rows.Count, 2).End(xlUp).Row)

Application.ScreenUpdating = False

Application.Calculation = xlCalculationManual

For i = ActiveSheet.UsedRange.Rows.Count + 1 To 3 Step -1

x = Application.WorksheetFunction.CountIf(MyRng, Cells(i, 2))

If x > 1 Then Cells(i, 2).EntireRow.Delete

Next i

Application.Calculation = xlCalculationAutomatic

Application.ScreenUpdating = True

End Sub

[عبدالله المجرب]

اخي الغريب

بفضل الله تبارك وتعالى

ثم بمساعدة الاستاذ كيماس (ابا عمر) حفظه الله ورعاة

تفضل الكود بعد التعديل

Sub dellduplicates()

Dim MyRng As Range

Set MyRng = Range(ActiveCell, Cells(Rows.Count, ActiveCell.Column))

MyRng.Select

Application.ScreenUpdating = False

Application.Calculation = xlCalculationManual

For i = ActiveSheet.UsedRange.Rows.Count + 1 To 3 Step -1

x = Application.WorksheetFunction.CountIf(MyRng, Cells(i, ActiveCell.Column))

If x > 1 Then Cells(i, ActiveCell.Column).EntireRow.Delete

Next i

Application.Calculation = xlCalculationAutomatic

Application.ScreenUpdating = True

End Sub

ابواحمد

[توكل]

الأخ أبو أحمد والأخ كيماس جزاكم الله كل خير

مع تحياتي