استخراج القيم الفريدة أي الغير مكررة في نطاق باستخدام الكائن القاموس

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

2 ساعات مضت, ياسر خليل أبو البراء said:

أخي الكريم محي الدين

لإضافة أوزراق عمل أخرى أو إضافة قيم جديد للمصفوفة الموجودة بالفعل .. أولاً لابد من عمل حلقة تكرارية لأوراق العمل المراد التعامل معها ثم تخزين القيم الجديدة في نفس المصفوفة قبل استخدام الكائن القاموس .. ويتم استخدام كلمة ReDim Preserve قبل تحديد أبعاد المصفوفة من جديد ، حتى يمكن للقيم الجديدة أن تدرج ، و في نهاية المطاف يتم التعامل معها مرة واحدة من خلال الكائن القاموس ..

السلام عليكم

استاذ ياسر

لا أدري حاولت مع redim presereve لكن ام تعمل معي

لذلك حاولت بطريقة أخرى فأدت إلى خطأ أرجو النظر في هذا الكود وتحديد الخطأ الذي ارتكبته بارك الله بك

Sub UniqueByDictionary()
'يقوم الكود باستخراج القيم الفريدة أي الغير مكررة باستخدام الكائن قاموس
'----------------------------------------------------------------------
    'المتغير الأول لتخزين قيم النطاق والمتغير الثاني لتخزين مفاتيح القاموس
    'الثالث متغير للكائن القاموس والرابع متغير يستخدم في عمل حلقة تكرارية
    Dim myData As Variant, Temp As Variant
    Dim Obj As Object, I, x As Long
    Dim lr1, lr2 As Long
    Sheet1.Activate
    
    lr1 = Cells(Rows.Count, 1).End(xlUp).Row
    ReDim myData(1 To lr1) As Variant
    Sheet2.Activate
    MsgBox UBound(myData)
    lr2 = Cells(Rows.Count, 1).End(xlUp).Row
    'ليساوي الكائن المسمى القاموس والذي يعتبر أداة قوية للتعامل مع القيم الفريدة [Obj] تعيين المتغير
    Set Obj = CreateObject("Scripting.Dictionary")
    
    'ليساوي قيم النطاق في العمود الأول [myData] تعيين المتغير
    myData = Sheet1.Range("A2:A" & lr1)

    ReDim myData(1 To lr1 + lr2) As Variant
MsgBox UBound(myData)
    For x = lr1 + 1 To UBound(myData)
     myData(x) = Sheet2.Range("A" & x)
     Next x
  
  
    'حلقة تكرارية تبدأ من أول عنصر في مصفوفة القيم إلى آخر عنصر في المصفوفة
    For I = 1 To UBound(myData)
        'هذا السطر هو أهم سطر في الكود حيث يتم تمرير القيمة للقاموس
        'فيقوم القاموس بتخزينها إذا كانت القيمة تصادفه لأول مرة
        'أما إذا كانت القيمة مكررة فلا يقوم بتخزينها مرة أخرى
        Obj(myData(I, 1) & "") = ""
    Next I
    
    'ليساوي مفاتيح القاموس والتي تمثل القيم الغير مكررة [Temp] تعيين المتغير
    Temp = Obj.Keys
    
    'حيث يتم تحديد عدد الصفوف [E1] وضع عناصر القاموس الغير مكررة في الخلية
    'والتي تقوم بعد عناصر القاموس التي تم تخزينها [Count] من خلال كلمة
    'عبارة عن مصفوفة بالقيم تكون على شكل أفقي لذا نستخدم [Temp] المتغير
    'لتحويل القيم من الشكل الأفقي إلى الشكل الرأسي ليناسب وضع النتائج في عمود [Transpose] كلمة
    Sheet3.Range("C1").Resize(Obj.Count, 1) = Application.Transpose(Temp)
End Sub

 

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

اخي الكريم محي الدين ارفق الملف الذي تعمل عليه لأحاول الإطلاع على الكود ..لم أرى في الكود أنك قمت بحلقة تكرارية .. إنما وضعت القيم لكل ورقة عمل بشكل منفصل

وبخصوص هذا السطر

 myData = Sheet1.Range("A2:A" & lr1)

ضع في نهايته كلمة Value مسبوقة بنقطة

ويرجى عند إرفاق الكود إرفاقه بدون الشرح لتكون الأسطر أسهل في القراءة ...

في انتظار ملفك المرفق لمحاولة التعديل عليه إن شاء الله

تقبل تحياتي

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

22 دقائق مضت, ياسر خليل أبو البراء said:

اخي الكريم محي الدين ارفق الملف الذي تعمل عليه لأحاول الإطلاع على الكود ..لم أرى في الكود أنك قمت بحلقة تكرارية .. إنما وضعت القيم لكل ورقة عمل بشكل منفصل

وبخصوص هذا السطر

 myData = Sheet1.Range("A2:A" & lr1)

ضع في نهايته كلمة Value مسبوقة بنقطة

ويرجى عند إرفاق الكود إرفاقه بدون الشرح لتكون الأسطر أسهل في القراءة ...

في انتظار ملفك المرفق لمحاولة التعديل عليه إن شاء الله

تقبل تحياتي

السلام عليم

اليك المرفق استاذي الكريم

بخصوص .value التي اشرت إليها

ذكرت لك سابقاً أني وضعت أحدى القيم معادلة بسيطة وحذفت .value في الكود الأساسي نقل قيمة المعادلة فالسءال هو ما فائدة .value هنا

بارك الله بك

 

Book1.rar

تم تعديل أبريل 3, 2016 بواسطه محي الدين ابو البشر

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

??

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

أخي الكريم محي الدين

إن شاء الله عندما أعود من العمل سأقوم بالعمل على ملفك .. لأن تخزين القيم من أكثر من ورقة عمل يحتاج لبعض العمل وليس كما ظننت في البداية ..

تقبل تحياتي

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

السلام عليكم

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

اسف أني اتعبك معي

جزاك الله كل خير

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

أخي الكريم محي الدين

جرب الكود التالي عله يفي بالغرض

Sub UniqueByDictionary()
    Dim myData(), Temp As Variant
    Dim Obj As Object, I As Long, intCtr As Long
    Dim X As Long, Y As Long
    
    X = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
    Y = Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Row
    
    Sheets("Sheet2").Rows("2:" & X).Insert
    myData = Evaluate("IF(ROW(2:" & X + Y & ")<=" & X & ",Sheet1!A2:A" & X & ",Sheet2!A2:A" & X + Y & ")")
    Sheets("Sheet2").Rows("2:" & X).Delete

    Set Obj = CreateObject("Scripting.Dictionary")
    
    For I = 1 To UBound(myData) - 1
        Obj(myData(I, 1) & "") = ""
    Next I
    
    Temp = Obj.Keys
    
    Sheet3.Range("A2").Resize(Obj.Count, 1) = Application.Transpose(Temp)
End Sub

تقبل تحياتي

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

السلام علكيم استاذ ياسر بارك الله لك وجزاك كا خير على جهودك وبحثك

اتعبتك معي

سامحني

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

أخي الفاضل محي الدين

إنت تؤمر يا كبير وكلنا بنستفيد في النهاية ..مفيش تعب ولا حاجة .. أنا أحب كل يوم أتعلم شيء جديد ودا فايدة التفاعل اللي قلت عليه

تقبل وافر تقديري واحترامي

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

السلام  عليكم

بعد اذنك استاذ ياسر

ماذا عن Redim preserve انت تغلبت علها بثلاثة أسطر 

Sheets("Sheet2").Rows("2:" & X).Insert
    myData = Evaluate("IF(ROW(2:" & X + Y & ")<=" & X & ",Sheet1!A2:A" & X & ",Sheet2!A2:A" & X + Y & ")")
    Sheets("Sheet2").Rows("2:" & X).Delete

لكن  فقط من أجل الإفادة أسأل

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

أخي الكريم محي الدين

إن شاء الله في الحلقات الجديدة من حلقات التعامل مع المصفوفات سيأتي شرحها بالتفصيل ..

ولكن هنا سيكون لابد من عمل حلقة تكرارية لكل عنصر لإضافة القيم من الورقة الثانية إلى المصفوفة ، من ثم ما قدم هو الأيسر بدلاً من الحلقات التكرارية .. التي يمكن الاستغناء عنها

تقبل تحياتي

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

السلام عليكم

استاذ ياسر

بارك الله بك 

وانا بالانتظار على أحر من لجمر مواضيعك الرائعة 

دمتم

 

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

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

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

أما بالنسبة للانتظار على أحر من الجمر ..فيبدو أن انتظارك وصبرك ضعيف بدليل الموضوع إياه

بس دا مش شيء وحش بالعكس دا شيء ممتاز .. عايزك تستنزف الناس دي ... حاول معاهم مرة واتنين .. لا تكتفي بمن يضع لك روابط ، فجوجل مليء بالراوبط لو أردت روابط ...

اطلب أمثلة للتوضيح وستجد الدرر

تقبل تحياتي

 

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

في 4/4/2016 at 21:48, ياسر خليل أبو البراء said:

أخي الكريم محي الدين

جرب الكود التالي عله يفي بالغرض

Sub UniqueByDictionary()
    Dim myData(), Temp As Variant
    Dim Obj As Object, I As Long, intCtr As Long
    Dim X As Long, Y As Long
    
    X = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
    Y = Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Row
    
    Sheets("Sheet2").Rows("2:" & X).Insert
    myData = Evaluate("IF(ROW(2:" & X + Y & ")<=" & X & ",Sheet1!A2:A" & X & ",Sheet2!A2:A" & X + Y & ")")
    Sheets("Sheet2").Rows("2:" & X).Delete

    Set Obj = CreateObject("Scripting.Dictionary")
    
    For I = 1 To UBound(myData) - 1
        Obj(myData(I, 1) & "") = ""
    Next I
    
    Temp = Obj.Keys
    
    Sheet3.Range("A2").Resize(Obj.Count, 1) = Application.Transpose(Temp)
End Sub

تقبل تحياتي

السلام عليكم

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

لكن عندما طبقته عملياً ظهرت لدي مشكلتين

الأولى أنه يعتبر الخلية الفارغة وهي موجودة عندي في ورقات العمل لا يمكنني إلغائها. 

المشكلة الثانية هي ان بعض الاسماء تبقى مكررة 

في المرفق تطبيق للكود وفي الشيت 3 النتيجة

أرجو إلقاء نظرة وابداء الرأي

جزاك الله كل خير 

القيم الفريدة.rar

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

أخي الحبيب محي الدين

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

بالنسبة لسؤال حول الخلايا الفارغة يمكن استخدام شرط لتفادي الخلايا الفارغة بهذا الشكل

    For I = 1 To UBound(myData) - 1
        If Not IsEmpty(myData(I, 1)) And myData(I, 1) <> 0 Then
            Obj(myData(I, 1) & "") = ""
        End If
    Next I

أما بالنسبة إلى أن بعض الأسماء مكررة هذا يرجع للإدخال فكلمة "أنس" غير كلة "انس" غير كلمة "إنس" ... وكلمة "محمد" غير كلمة "محمد " الثانية بها مسافة زائدة ...

تقبل تحياتي

 

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

السلام عليكم

استاذي العزيز ياسر  بارك الله بك وارجوك ان تعذرني

بالنسبة للسؤال الثاني :

اذا لا حظت أن الأسماء المكررة (غير لون) وهذا ناتج عن تنسيق شرطي فهل الاكسل لا يميز بين اسمين فيهما فراغ زائد مثلاً

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

 

أرجو الإفادة

وجزالك الله خيراً

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

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

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

استاذي الحبيب ياسر يبدو أني لم اوضح بشكل جيد

الرجاء في الشيت 2 التي هي النتيجة لاحظ أن لورين أحمد مكرر  مرتين A16 & A33 وهما متطابقين تماما حتى انني اضفت فراغا لاحدهما فاعتبرهما الاكسل في التنسيق الشرطي غير مكررين

وايضا نسخت الاسم في الشيت 1 نسخ  وجربت الماكرو فاعطى نفس النتيجة بالمناسبة ليست كل الاسماء ام انني اعمل شيئ خاطيء

تعبت

يوجد مشكلة ما في مكان ما

 

 

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

لم أفهم المشكلة ..

اطلعت على ورقة العمل التي بها النتائج ووجدت أن الاسم مختلف حيث الاسم "لورين احمد" في الخلية A16 ووجد الاسم "لورين أحمد" في الخلية A33 ... لاحظ الهمزة ف الاسم أحمد في المرة الثانية ...

حاول توضح المشكلة بالصور لو لم تكن واضحة بالنسبة لي ..

 

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

السلام عليكم

ليس الزهايمر  لكن يبدو أن النظارات بحاجة إلى سماكة أكثر مما عندي

استميحك عذراً 

العتب على البصر 

اسف جداً شكراً على وقتك الثمين

وجزاك الله كل خير على كل ثانية امضياتها معي

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

وعليكم السلام أخي الحبيب محي الدين

الحمد لله أن انتبهت للخطأ الموجود ..أما بخصوص الزهايمر فالحال من بعضه ، وكلنا هذا الرجل

وجزيت خيراً بمثل ما دعوت لي ، وتأكد أنني أستمتع بالتفاعل المثمر الذي يعلمني قبل أن يعلم غيري

تقبل تحياتي