ازالة التكرار مع الاحتفاظ بالمدخلات الاخيرة وحذف القديمة

[world liner]

السلام عليكم

اخواني الكرام

لدي الكود التالي وهو يعمل على اكمل وجه بحيث يتم حذف التكرار ( يقوم بالاحتفاظ بالمدخلات القديمة ويحذف المتكرر من المدخلات الجديدة اوالصفوف الاخيرة )

 

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

 

Sub duplicate_AWB()
LR = [m400].End(xlUp).Row
For r = LR To 4 Step -1
    x = Cells(r, 13).Value
    If WorksheetFunction.CountIf(Range("m4:m" & LR), x) > 1 Then
        Cells(r, 3).Offset("0,0").Resize(1, 25).ClearContents
        End If
Next r


End Sub

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

كيف يميز الكود بين المدخلات القديمة والجديدة؟؟؟

[سليم حاصبيا]

السلام عليكم 

اخي الكريم

اليك هذا الكود /تستطيع ان تعدل عليه بالنسبة لعدد الأعمدة والبيانات

ترك اخر مكرر.rar

[world liner]

كيف يميز الكود بين المدخلات القديمة والجديدة؟؟؟

عند لصف المدخلات الجديدة يتم التعرف على المتكرر عن طريق العمود M والذي يحتوي على رقم المرجع ، تنبيه باللون الازرق الداكن يظهر في العمود A للمدخلات المتكررة ، بالمرفقات الملف الذي اعمل عليه ، عند فتح الملف ستجد تنبيه ل8 صفوف فيها تكرار ، 4 مدخلات قديمة و4 مدخلات جديدة بالاسفل لاكنها متكررة ، يوجد زر remove duplicate بالاعلي وعند الضغط عليه سوف يطبق الكود التالي ، الكود سوف يحذف المتكرر الجديد اي من الاسفل الي الاعلي ، المطلوب زر اخر يعمل نفس الوظيفة لاكن يحذف المتكرر من الاعلي الي الاسفل وبدون فرز .لعدم خبرتي لم استطلع التعديل على الكود لكي يقوم بحذف المتكرر من الاعلي الي الاسفل .

 

Sub duplicate_AWB()

LR = [m400].End(xlUp).Row

For r = LR To 4 Step -1

    x = Cells(r, 13).Value

    If WorksheetFunction.CountIf(Range("m4:m" & LR), x) > 1 Then

        Cells(r, 3).Offset("0,0").Resize(1, 25).ClearContents

        End If

Next r

Test.rar

[عبدالله باقشير]

السلام عليكم

 

ممكن هذا التعديل الطفيف

وهو تعديل فورنكست لتبدأ من الاعلى الى الاسفل

Sub duplicate_AWB()
lr = [m400].End(xlUp).Row
For r = 4 To lr
    x = Cells(r, 13).Value
    If WorksheetFunction.CountIf(Range("m4:m" & lr), x) > 1 Then
        Cells(r, 3).Resize(1, 25).ClearContents
    End If
Next r
End Sub

تحياتي

[world liner]

السلام عليكم

 

ممكن هذا التعديل الطفيف

وهو تعديل فورنكست لتبدأ من الاعلى الى الاسفل

Sub duplicate_AWB()
lr = [m400].End(xlUp).Row
For r = 4 To lr
    x = Cells(r, 13).Value
    If WorksheetFunction.CountIf(Range("m4:m" & lr), x) > 1 Then
        Cells(r, 3).Resize(1, 25).ClearContents
    End If
Next r
End Sub

تحياتي

 

الف شكر وبالفعل هذا هو المطلوب ، اشكر لك مساعدتك.

 

 

السلام عليكم 

اخي الكريم

اليك هذا الكود /تستطيع ان تعدل عليه بالنسبة لعدد الأعمدة والبيانات

 

 

الشكر الجزيل لك على الرد والمساعدة.