استخراج القيم الفريده .. بطريقه العلامه عبد الله باقشير

[ناصر سعيد]

بسم الله الرحمن الرحيم

استخراج القيم الفريده بطريقة العلامه عبد الله باقشير .. حفظه الله ورعاه

مع شرح الكود

جزى الله كل من ساهم في اخراج هذا العمل الى النور بكل خير

Private Sub Worksheet_Activate()
'هذاالكود خاص بالعلامه عبد الله باقشير
'حفظه الله
' الهدف من الكود هو الاتيان بالقيم الفريده
'تم هذا الكود في  23/06/2007
'' '' '' '' '' '' '' '''' '' '' '' '' '' '' ''
Application.ScreenUpdating = False

'مسح عمود القيم الفريده
[V5:V500].ClearContents

'متغير عمود القيم الفريده
Set MyRange = [V5:V500]

'اسم شيت المصدرورقم صف البدايه في شيت المصدر
For U = 7 To Sheets("رصد الترم الثانى").[C1500].End(xlUp).Row

'رقم عمودالبيانات الفريده ورقم عمود بيانات المصدر
   Cells(U, 22) = Sheets("رصد الترم الثانى").Cells(U, 4)
   
   'رقم عمودالبيانات الفريدهفي الشيت الهدف
If Application.WorksheetFunction.CountIf(MyRange, Cells(U, 22)) > 1 Then

'رقم عمودالبيانات الفريده
   Cells(U, 22).ClearContents
End If
Next

'فرز عمود القيم الفريده
[V5:V500].Sort [V5], xlAscending

   Application.ScreenUpdating = True
End Sub

 

استخراج القيم الفريده.rar

تم تعديل أبريل 27, 2017 بواسطه ناصر سعيد
تنسيقات

[أ / محمد صالح]

ما شاء الله

أخي خبور خير رائع وجميع أكواده بسيطة وفعالة أعاده الله لنا وسلمه من كل سوء

ولإثراء الموضوع أقدم هذه المعادلة لنفس الغرض

=INDEX($a$2:$a$1000,MATCH(0,COUNTIF($D$1:D1,$a$2:$a$1000),0))

حيث وجود البيانات في العمود a ويتم كتابة المعادلة في الخلية d2 مع الضغط على

Ctrl+shift+enter

لأنها معادلة صفيف array formula

ثم تسحب لأسفل

وفقنا الله جميعا للخير

دمتم في رعاية الله وحفظه

[ناصر سعيد]

الاستاذ الكبير محمد صالح  ... بارك الله فيك وحفظك من كل سوء

من فضلك

ضع ملفا لمعادلتك

بشرط ان يكون النتائج في صفحة مختلفه عن صفحة البيانات

[أ / محمد صالح]

يمكنك تعديل المعادلة ومصدر البيانات إلى

=INDEX(sheet1!$a$2:$a$1000,MATCH(0,COUNTIF($D$1:D1,sheet1!$a$2:$a$1000),0))

حيث الشيت هو sheet1

والعمود الذي به البيانات هو a2:a1000

 

[ناصر سعيد]

الاستاذ المحترم محمد صالح

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

تعطي هذه الرساله

 

[أ / محمد صالح]

يبدو أنه لم يتم تنفيذ المطلوب بصورة صحيحة

يوجد خطأ في الخطوات

[ناصر سعيد]

تم فتح شيت جديد

في ورقة

sheet1

وفي العمود A

وفي الخليه التانيه وضعنا ارقام عشوائيه مكرره

وفي الورقه التانيه وضعنا معادلتك ...  من فضلك اين الخطأ في الخطوات ؟

 

[أ / محمد صالح]

توضع البيانات المكررة في العمود a في sheet1

توضع المعادلة في الصفحة الثانية في الخلية d2

ثم تسحب لأسفل

مع مراعاة نظام الفاصلة بين أجزاء المعادلات في جهازك هل هي 

,

أو

;

حسب إعدادات اللغة

هدانا الله جميعا لما فيه الخير

 

 

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

9 دقائق مضت, ناصر سعيد said:

تم فتح شيت جديد

في ورقة

sheet1

وفي العمود A

وفي الخليه التانيه وضعنا ارقام عشوائيه مكرره

وفي الورقه التانيه وضعنا معادلتك ...  من فضلك اين الخطأ في الخطوات ؟

 

جرب استبدال الفاصلة ", " بفاصلة منقوطة بالمعادلة";"

[ناصر سعيد]

=INDEX(Sheet1!$A$2:$A$1000; MATCH(0; COUNTIF($D$1:D5; Sheet1!$A$2:$A$1000); 0))

شكرا لسعة صدركم .. المشكله كانت الفاصله

هل يمكن ازاله الخطأ الذي يظهر عند وجود المعادله وعدم وجود قيم فريده اخرى

[أ / محمد صالح]

لعدم عرض الخطأ يتم إضافة

Iferror ثم فتح قوس قبل المعادلة

وفي نهايتها فاصلة ثم علامتي تنصيص ثم غلق القوسلتصبح المعادلة

=iferror(INDEX(Sheet1!$A$2:$A$1000; MATCH(0; COUNTIF($D$1:D5; Sheet1!$A$2:$A$1000); 0)):"")

بالتوفيق

[ناصر سعيد]

شكرا لسعة صدرك استاذ محمد صالح

وشكرا للاستاذ سليم حاصبيا

[ناصر سعيد]

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

ارجو توضيح كبف اجعل صف صفحة بيانات المصدر مختلفه عن صف بيانات الهدف

يعني في الكود الموجود الصف التاسع ..... ليضع البيانات الفريده في الصف التاسع

وياخذ البيانات من صفحة المصدر من الصف التاسع

واحنا عايزين نجعل ياخد بيانات المصدر من الصف السابع

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

أخي العزيز ناصر

حاول تتبع الكود باستخدام مفتاح F8 من لوحة المفاتيح لتلاحظ التغيرات التي تحدث بعد كل سطر

سأعطيك مثال من الكود لتعرف الأجزاء المهمة في السطر

'رقم عمودالبيانات الفريده ورقم عمود بيانات المصدر
   Cells(U, 22) = Sheets("رصد الترم الثانى").Cells(U, 4)

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

'اسم شيت المصدرورقم صف البدايه في شيت المصدر
For U = 7 To Sheets("رصد الترم الثانى").[C1500].End(xlUp).Row

فالمتغير المسمى U يحمل في أول حلقة تكرارية القيمة 7 ... من ثم فإن السطر الذي أعطيك مثالاً له يكون بالشكل التالي إذا قمنا بترجمته

Cells(7, 22) = Sheets("رصد الترم الثانى").Cells(7, 4)

الشق الأول لا توجد فيه إشارة لورقة العمل حيث أن الكود موضوع في حدث تنشيط ورقة العمل Worksheet_Activate ، فإنه يفهم أن الخلية في الصف رقم 7 والعمود 22 في الورقة التي تحتوي الكود (الورقة الهدف) التي توضع فيها القيم الفريدة

والشق الثاني يشير للورقة المصدر التي تحتوي البيانات الخام في الصف السابع والعمود الرابع

 

كيف يمكن أن أغير صف البداية في ورقة العمل المصدر أو الهدف ؟ ببساطة يمكنك التحكم في المتغير U حيث يمكنك إضافة قيمة محددة ...

على سبيل المثال إذا كانت البيانات الخام تبدأ من الصف رقم 10 فإنه في الجزء الذي يتعامل مع البيانات الخام يتم إضافة 3 لقيمة المتغير U لتحصل على الرقم 10 ، ليكون بهذا الشكل

Cells(U, 22) = Sheets("رصد الترم الثانى").Cells(U+3, 4)

هذا مجرد مثال لتتضح الصورة ، ويمكنك تطويع الكود كما ترغب حسب هيكلة وحالة الملف

وتقبل تحياتي

[ناصر سعيد]

الله اكبر ... الله اكبر   .. ربنا يحفظك ويصونك يا استاذ ياسر

 

=====

شرح ولا اسهل

 

القيم الفريــده.rar

وهذا تطبيق الشرح

[ناصر سعيد]

'Private Sub Worksheet_Activate()
Sub القــيم_الفريده()
'Private Sub Worksheet_Activate()

'هذاالكود خاص بالعلامه عبد الله باقشير
'حفظه الله
' الهدف من الكود هو الاتيان بالقيم الفريده
'تم هذا الكود في  23/06/2007
'' '' '' '' '' '' '' '''' '' '' '' '' '' '' ''
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False

'مسح عمود القيم الفريده
[S9:S500].ClearContents

'متغير عمود القيم الفريده
Set MyRange = [S9:S500]

'اسم شيت المصدرورقم صف البدايه في شيت الهدف
For U = 9 To Sheets("بيانات الطلبة").[C1500].End(xlUp).Row

'رقم عمودالبيانات الفريده ورقم عمود بيانات المصدروكذلك رقم الصف في شيت المصدر
   Cells(U, 19) = Sheets("بيانات الطلبة").Cells(U - 2, 22)
   
   'رقم عمودالبيانات الفريده في الشيت الهدف
If Application.WorksheetFunction.CountIf(MyRange, Cells(U, 19)) > 1 Then

'رقم عمودالبيانات الفريده
  Cells(U, 19).ClearContents
End If
Next

'فرز عمود القيم الفريده
[S9:S500].Sort [S9], xlAscending

   Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True

End Sub

ربنا يبارك لك استاذ ياسر خليل

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

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

والحمد لله الذي هدانا لهذا وما كنا لنهتدي لولا أن هدانا الله

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

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

بعد اذن اخي ياسر هذا الكود

Option Explicit
Option Base 1

Sub Give_Uniques()
Dim j, x As Integer
Dim First_Sh, Sec_Sh As Worksheet
Dim sn
Dim Obj As Object
 Set First_Sh = Sheets("بيانات الطلبة"): Set Sec_Sh = Sheets("اوائل ")

   sn = First_Sh.Range("v7:v" & Cells(Rows.Count, "v").End(xlUp).Row)
     With CreateObject("System.Collections.ArrayList")
    For j = 1 To UBound(sn)
        If sn(j, 1) <> vbNullString Then
            If Not .Contains(sn(j, 1)) Then .Add sn(j, 1): x = x + 1
        End If
    Next
    .Sort
    Sec_Sh.Range("s9").Resize(x) = Application.Transpose(.toarray)
  End With
End Sub

 

[ناصر سعيد]

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

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

ربنا يزيك علما وحلما يارب العالمين .. وبعد

الكود يعطي هذه الرساله

 

 

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

ممكن ترفق الملف الذي به المشكلة وتصور رسالة الخطأ التي تظهر لك مع ظهور السطر الأصفر ..

ما هي نسخة الويندوز التي تعمل عليها ونسخة الأوفيس التي تعمل عليها؟

[ناصر سعيد]

نسخه الويندوز اكس بي

اوفيس 2010

صوره الخطأ تم تصويرها

الملف مرفق

القيم الفريــده.rar

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

تعديل طفيف جداً في الكود .. والكود يعمل بشكل جيد لدي (ويندوز 7 ونسخة أوفيس 2016)

Option Base 1

Sub GiveUniques()
    Dim j           As Long
    Dim x           As Long
    Dim First_Sh    As Worksheet
    Dim Sec_Sh      As Worksheet
    Dim sn          As Variant
    Dim Obj         As Object

    Set First_Sh = Sheets("بيانات الطلبة"): Set Sec_Sh = Sheets("اوائل ")
    sn = First_Sh.Range("V7:V" & First_Sh.Cells(Rows.Count, "v").End(xlUp).Row)

    With CreateObject("System.Collections.ArrayList")
        For j = 1 To UBound(sn)
            If sn(j, 1) <> vbNullString Then
                If Not .Contains(sn(j, 1)) Then .Add sn(j, 1): x = x + 1
            End If
        Next j
        .Sort
        Sec_Sh.Range("S9").Resize(x) = Application.Transpose(.toarray)
    End With
End Sub

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

 

.NET Framework

Supported in: 4, 3.5, 3.0, 2.0, 1.1, 1.0

[ناصر سعيد]

جزاك الله خيرا .. نفس صوره الخطأ السابقه

[أ / محمد صالح]

جميع أكواد السادة الزملاء تعمل بكفاءة ولا يوجد أخطاء

وربما تصوير نص رسالة الخطأ وليس شاشة الكود بعد إغلاق الرسالة يفيد في الوصول للحل في مشكلة الكود الرابع

[ناصر سعيد]

اشكركم على ردودكم .. جزاكم الله خيرا

وبعد

يظهر الخط الاصفر على نفس السطر الموجود بالصوره المرفقه تبعنا

ولاتظهر اي رساله كتابيه اخرى ... انا اعتبرت ان الخط الاصفر على سطر في الكود تعتبر رساله من وجهة نظري