كود لحذف البيانات المكررة بين عمودين

[عاشق الاكسيل]

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

اساتذتى الاعزاء

ارجو التفضل بكود يمكننى من حذف البيانات المكررة بين عمودين

لدى ارقام فى العمود A وارقام فى العمود B اريد كود لحذف القيم المتساوية فى العمودين

مع مراعاة مثلا تواجد الرقم 1 مرتين فى العمود 1 وتواجد مرة فى العمود 2

يقوم الكود بمسح رقم 1 مرة من العمود 1 ومرة من العمود 2 ويتبقى رقم 1 مرة واحد فى العمود 1

مرفق ملف

 

Target.rar

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

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

ارفق النتائج المتوقعة حسب الملف المرفق ليسهل فهم الموضوع ويسهل الوصول لحل

قرأت المشاركة أكثر من مرة في محاولة مني لفهم المطلوب بشكل كامل إلا أنني لم أوفق ..

 

[عاشق الاكسيل]

مرفق ملف يوضح النتيجة المطلوبة

Target.rar

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

بصراحة منطق الطلب غريب شوية ..

يعني من المفترض لو هبدأ من أول خلية ولاقيت فيها رقم 1 من المفترض إنه نحتفظ بيه عشان دا أول حدوث له بس اللي حصل إنك حذفته والرقم 1 الأول في العمود الثاني بردو حذفته

وأبقيت على آخر رقم 1 ...فهل أفهم من كدا إن المطلوب الاحتفاظ بآخر حدوث للرقم؟

طيب الرقم 3 موجود هنا في العمود الأول واتحذف وموجود في العمود الثاني واتحذف ، ولم يتم الإبقاء على أي منهما ..فهل ذلك صحيح؟

أرجو توضيح المنطق ........

[عاشق الاكسيل]

ببساطة شديدة استاذى ياسر خليل

المطلوب هو لعمل تسوية للحسابات بين جانبى المدين والدائن

فيتم مسح الرقم المكرر تواجده فى عمود المدين والعمود الدائن ولكن قد يحدث تواجد الرقم مرتين فى عمود المدين وموجود مرة واجدة فى عمود الدائن

لذلك تم مسح الرقم من جانبى المدين والدائن والابقاء عليه مرة واحدة فى عمود المدين لعدم وجود تكرار له فى عمود الدائن ارجو ان تتضح الفكرة

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

صراحة لا أفهم في لغة الدائن والمدين ولذا أسألك هل النتائج المرفقة منك صحيحة تماماً .. وما هو المنطق المتبع إذاً ..؟؟

لطفاً رافق نتائج صحيحة تماماً مع شرح لمنطق عملية المسح

[عاشق الاكسيل]

النتائج المرفقة صحيحية 100%

المنطق المتبع كالاتى :

نطاق المقارنة :

عمود A و عمود B

الية التنفيذ :

يقوم الكود بفحص تكرار الخلية A1 " بداية النطاق " فى كامل العمود B

اذا تم العثور على تكرار يقوم بمسح قيمة الخلية A1 والخلية المكررة لنفس القيمة فى العمود B

ثم يقوم بتكرار العملية تباعا الخلية A2 و A3 ............ الخ حتى نهاية النطاق المحدد

تطبيق على المرفق :

بدء الكود بالخلية A1  بحثا عن تكرار فى العمود B تم العثور على خلية بنفس القيمة وهى خلية B3

يقوم الكود بمسح الخلية A1 و الخلية B3

يبدء فى تكرار العملية مرة اخرى بالبحث عن قيمة الخلية A2 لم يجد تكرار

يكرر العملية بالبحث عن قيمة الخلية A3 تم العثور على خلية بنفس القيمة وهى خلية B7

يقوم الكود بمسح الخلية A3 و B7

ثم تكرار العملية لحين انتهاء من النطاق المحدد وازاحة الخلايا لاعلى لتظهر بالشكل النهائى فى العمودين M و N

ارجو ان اكون وفقت فى الشرح

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

ربما كان المطلوب في هذا الكود

Sub del_dupl()
 Dim Source_Rg, target_rg As Range
 Dim rg_to_del As Range
 Dim m, n, i, j As Integer
 
 Set Source_Rg = Range("a1:a8")
 Set target_rg = Range("b1:b8")
  m = Source_Rg.Count
  n = target_rg.Count
   For i = 1 To m
     For j = 1 To n
       If Cells(i, 1) = Cells(j, 2) Then
            If rg_to_del Is Nothing Then
             Set rg_to_del = Union(Cells(i, 1), Cells(j, 2))
             Else
             Set rg_to_del = Union(rg_to_del, Cells(j, 2))
'             rg_to_del.Select
            End If
        End If
        Next
        If rg_to_del Is Nothing = False Then
'        rg_to_del.Select
        rg_to_del = ""
        Set rg_to_del = Nothing
         End If
        Next
End Sub

 

[ابو عبدالرحمن البغدادي]

عاشت الايادي

تمام

 

[عاشق الاكسيل]

استاذى سليم حاصبيا

شكرا لك على الكود .

الكود اقرب ما يكون الى المطلوب

ولكن يتبقى تعديل واحد على الكود ليحقق النتيجة المطلوبة

يلاحظ عند استخدام الكود انه يقوم بمسح الخلية فى العمود A ومسح جميع الخلايا المساوية لها فى القيمة فى العمود B

ولكن المطلوب هو مسح الخلية من العمود A  ومسح اول خلية مساوية لها فى العمود B وليس جميع الخلايا المساوية لها

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

تم التعديل حسب المطلوب

Sub del_dupl1()
 Dim Source_Rg, target_rg As Range
 Dim rg_to_del As Range
 Dim m, n, i, j As Integer
 
 Set Source_Rg = Range("a1:a8")
 Set target_rg = Range("b1:b8")
  m = Source_Rg.Count
  n = target_rg.Count
  
   For i = 1 To m
     For j = 1 To n
                If Cells(i, 1) = Cells(j, 2) Then
                   Union(Cells(i, 1), Cells(j, 2)) = "": Exit For
                End If
     Next
  Next
End Sub

 

[عاشق الاكسيل]

استاذى سليم حاصبيا

لك كامل الاحترام والتقدير على هذا الكود

الكود يعمل بشكل ممتاز وحقق النتيجة المطلوبة تماما

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

12 دقائق مضت, عاشق الاكسيل said:

استاذى سليم حاصبيا

لك كامل الاحترام والتقدير على هذا الكود

الكود يعمل بشكل ممتاز وحقق النتيجة المطلوبة تماما

يمكن اضافة هذين السطرين الى نهاية الكود

مباشرة قبل End Sub

Source_Rg.SpecialCells(4).Delete Shift:=xlUp
target_rg.SpecialCells(4).Delete Shift:=xlUp