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



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





استخراج القيم المكررة فقط

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



10-10-2018 12:09 صباحا
Eslam Abdullah
menu_open
مشرف على لغات برمجة آخرى
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 03-10-2017
رقم العضوية : 852
المشاركات : 1158
الجنس : ذكر
تاريخ الميلاد : 1-9-1995
الدعوات : 2
يتابعهم : 3
يتابعونه : 55
قوة السمعة : 6904
الاعجاب : 1950
 offline 

السلام عليكم ورحمة الله وبركاته
أهلا ومرحبا بكم أخوانى الكرام موضوع اليوم هو تقديم حل لاحدى المشكلات


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

Mjk1Njk1MQ3030005
كما موضح بالصورة الحل ب3 طرق واحدة باستخدام معادلات الصفيف وأخرى بإستخدام دالة معرفة وأخرى بإستخدام كود VBA
جميع الحلول تأخذ القيم التى تم تكرارها فقط ونقل قيمة واحدة لكل منهم فى عمود أخر ويتم تجاهل الخلايا الفارغة
معادلة الصفيف فى الخلية B2 كالتالى

=IFERROR(INDEX($A$2:$A$11,SMALL(IF(FREQUENCY(IF($A$2:$A$11<>"",MATCH($A$2:$A$11,$A$2:$A$11,0),""),MATCH($A$2:$A$11&"",$A$2:$A$11&"",0))>1,ROW($A$2:$A$11)-ROW($A$2)+1,""),ROWS($C$2:C2))),"")

بعد كتابة المعادلة نضغط على Ctrl+Shift+Enter لانها معادلة صفيف

كود الدالة المعرفة AlsaqrDuplicate كالتالى
Function AlsaqrDuplicate(rng As Range, rw As Long)
'Programming by Eslam Abdullah
Dim Content As New Collection, i&
On Error Resume Next
     For i = 1 To rng.Find("*", , , , , 2).Row
        If rng.Cells(i).Value <> "" And Application.CountIf(rng, rng.Cells(i)) > 1 Then _
           Content.Add rng.Cells(i), CStr(rng.Cells(i))
        If Content.Count = rw Then AlsaqrDuplicate = Content.Item(rw): Exit Function
     Next i
     AlsaqrDuplicate = ""
End Function

استخدام الدالة بسيط جدا تتكون من 2 باراميتر الأول هو النطاق والثانى هو رقم تسلسل القيمة المستخرجة
كود الVBA كالتالى
Sub Duplicate()
'Programming by Eslam Abdullah
Dim dic As Object, lr&, i&
Cells(2, 4).Resize(Rows.Count - 1).ClearContents
    Set dic = CreateObject("Scripting.Dictionary"): dic.CompareMode = 1
    lr = Cells(Rows.Count, 1).End(3).Row
        For i = 2 To lr
            If Not dic.Exists(Cells(i, 1).Value) And Cells(i, 1).Value <> "" And Application.CountIf(Range("A2:A" & lr), Cells(i, 1)) > 1 Then _
            dic(Cells(i, 1).Value) = Cells(i, 1).Value
        Next i
    Cells(2, 4).Resize(dic.Count).Value = Application.Transpose(dic.Items)
End Sub


المثال قدامك فى الصوره والمعادلات والاكواد قدامك انقلها وبكدا انت فى غنى عن تحميل اى ملف
وللدعم البسيط تحميل ملف العمل لرؤية الروابط والمرفقات عليك الرد على الموضوع

كان معكم ومعنا ومعاهم برضوا أخاكم فى الله اسلام عبدالله
دمتم فى حفظ الله ورعايته 81




لرؤية الروابط والمرفقات عليك الرد على الموضوع


أثارت هذه المشاركة إعجاب: السعيد الجزائري، YasserKhalil، الصقر، ali mohamed ali، مهند محسن، salim،





10-10-2018 06:45 صباحا
مشاهدة مشاركة منفردة [1]
YasserKhalil
menu_open عضوية موثقة
مراقب عام
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 3
المشاركات : 4651
الجنس : ذكر
تاريخ الميلاد : 1-10-1978
الدعوات : 11
يتابعهم : 0
يتابعونه : 318
قوة السمعة : 13379
الاعجاب : 4951
 offline 
look/images/icons/i1.gif استخراج القيم المكررة فقط
بارك الله فيك أخي الحبيب إسلام وجزاك الله كل خير ، وجعل ما تقدمه يكون لك شفيعاً إنك تاخد اعفا من الجيش

أثارت هذه المشاركة إعجاب: Eslam Abdullah،




10-10-2018 06:56 صباحا
مشاهدة مشاركة منفردة [2]
الصقر
menu_open عضوية موثقة
مراقب عام
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 2
المشاركات : 1413
الجنس : ذكر
الدعوات : 12
يتابعهم : 0
يتابعونه : 359
قوة السمعة : 11277
الاعجاب : 2793
 offline 
look/images/icons/i1.gif استخراج القيم المكررة فقط

جزاكم الله خيرا يا غالى 3



أثارت هذه المشاركة إعجاب: YasserKhalil، Eslam Abdullah،




10-10-2018 07:26 صباحا
مشاهدة مشاركة منفردة [3]
khaled alborene
menu_open
عضو ماسي
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 22-08-2017
رقم العضوية : 16
المشاركات : 512
الجنس : ذكر
تاريخ الميلاد : 9-9-1990
الدعوات : 1
يتابعهم : 7
يتابعونه : 6
قوة السمعة : 561
الاعجاب : 220
 Online 
look/images/icons/i1.gif استخراج القيم المكررة فقط
سلمت يمناك

أثارت هذه المشاركة إعجاب: Eslam Abdullah،




10-10-2018 09:03 صباحا
مشاهدة مشاركة منفردة [4]
Eslam Abdullah
menu_open
مشرف على لغات برمجة آخرى
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 03-10-2017
رقم العضوية : 852
المشاركات : 1158
الجنس : ذكر
تاريخ الميلاد : 1-9-1995
الدعوات : 2
يتابعهم : 3
يتابعونه : 55
قوة السمعة : 6904
الاعجاب : 1950
 offline 
look/images/icons/i1.gif استخراج القيم المكررة فقط
مشكور مروركم الغالى أساتذتى الأحباء ياسر وحسام
ومشكور مروركم الكريم أستاذ خالد
وربنا يسمع منك وأخد اعفا biggrin2

أثارت هذه المشاركة إعجاب: الصقر، YasserKhalil،




10-10-2018 09:54 صباحا
مشاهدة مشاركة منفردة [5]
ali mohamed ali
menu_open
عضو محترف
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 20-11-2017
رقم العضوية : 1757
المشاركات : 522
الدولة : مصر
الجنس : ذكر
يتابعهم : 0
يتابعونه : 22
قوة السمعة : 2659
الاعجاب : 825
 offline 
look/images/icons/i1.gif استخراج القيم المكررة فقط
بارك الله فيك استاذ اسلام موضوع قيم ومطلوب دائما جعله الله فى ميزان حسناتك
وأتمنى من الله الكريم اذا كان هذا طلبك ورغبتك فى الإعفا ان يعطيك ويمن الله الكريم العزيز عليك بكل ما ترغب وتحب ان شاء الله

أثارت هذه المشاركة إعجاب: Eslam Abdullah، YasserKhalil،


توقيع :ali mohamed ali
{ وَقُل رَّبِّ زِدْنِي عِلْمًا }
[ كن على يقين من اعمالنا نخطئ ومن اخطائنا نتعلم ولذلك لا شي مستحيل ]
ساهم دائماً فى حل أى مشكلة او أستفسار لديك مع إضافة رد بشكره
أو دعوة لمن قدم اليك المساعدة,فالجميع هنا يعمل على مساعدة
 الاخرين لوجه الله وان تحتسب له اجر عند الله


10-10-2018 11:27 صباحا
مشاهدة مشاركة منفردة [6]
Eslam Abdullah
menu_open
مشرف على لغات برمجة آخرى
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 03-10-2017
رقم العضوية : 852
المشاركات : 1158
الجنس : ذكر
تاريخ الميلاد : 1-9-1995
الدعوات : 2
يتابعهم : 3
يتابعونه : 55
قوة السمعة : 6904
الاعجاب : 1950
 offline 
look/images/icons/i1.gif استخراج القيم المكررة فقط
مشكور مرورك العطر ودعائك الطيب أستاذ على 81

أثارت هذه المشاركة إعجاب: ali mohamed ali،




10-10-2018 11:46 صباحا
مشاهدة مشاركة منفردة [7]
مهند محسن
menu_open
عضو فعال
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 21-03-2018
رقم العضوية : 5025
المشاركات : 133
الجنس : ذكر
تاريخ الميلاد : 19-3-1990
يتابعهم : 0
يتابعونه : 4
قوة السمعة : 242
الاعجاب : 102
 offline 
look/images/icons/i1.gif استخراج القيم المكررة فقط
أحسنت استاذ اسلام بارك الله فيك

أثارت هذه المشاركة إعجاب: Eslam Abdullah،




10-10-2018 02:59 مساء
مشاهدة مشاركة منفردة [8]
Eslam Abdullah
menu_open
مشرف على لغات برمجة آخرى
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 03-10-2017
رقم العضوية : 852
المشاركات : 1158
الجنس : ذكر
تاريخ الميلاد : 1-9-1995
الدعوات : 2
يتابعهم : 3
يتابعونه : 55
قوة السمعة : 6904
الاعجاب : 1950
 offline 
look/images/icons/i1.gif استخراج القيم المكررة فقط
مشكور مرورك العطر على الموضوع المتواضع أستاذ مهند 81

أثارت هذه المشاركة إعجاب: مهند محسن،




10-10-2018 06:18 مساء
مشاهدة مشاركة منفردة [9]
salim
menu_open
خبير معتمد
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 22-08-2017
رقم العضوية : 43
المشاركات : 190
الجنس : ذكر
تاريخ الميلاد : 1-5-1989
يتابعهم : 13
يتابعونه : 6
قوة السمعة : 2081
الاعجاب : 427
 offline 
look/images/icons/i1.gif استخراج القيم المكررة فقط
بارك الله بك اخي حسام
و زيادة في اثؤاء الموضوع  هذا الكود

Option Explicit
Sub Extarct_dup()
Dim r%, m%: m = 4
Dim x%, Y%, k%
Range("d1").CurrentRegion.Offset(1, 0).Columns(1).ClearContents
r = Range("a1").CurrentRegion.Columns(1).Rows.Count
k = 2
Do Until k > r
    x = Application.CountIf(Cells(2, 1).Resize(r, 1), Cells(k, 1))
    Y = Application.CountIf(Cells(2, 4).Resize(k - 1, 1), Cells(k, 1))
       If x > 1 And Y = 0 Then
         Cells(m - 2, 4) = Cells(k, 1)
         m = m + 1
       End If
       k = k + 1
Loop
End Sub


أثارت هذه المشاركة إعجاب: Eslam Abdullah، YasserKhalil،




10-10-2018 08:53 مساء
مشاهدة مشاركة منفردة [10]
Eslam Abdullah
menu_open
مشرف على لغات برمجة آخرى
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 03-10-2017
رقم العضوية : 852
المشاركات : 1158
الجنس : ذكر
تاريخ الميلاد : 1-9-1995
الدعوات : 2
يتابعهم : 3
يتابعونه : 55
قوة السمعة : 6904
الاعجاب : 1950
 offline 
look/images/icons/i1.gif استخراج القيم المكررة فقط
المشاركة الأصلية كتبت بواسطة: salim »
بارك الله بك اخي حسام
و زيادة في اثؤاء الموضوع  هذا الكود

Option Explicit
Sub Extarct_dup()
Dim r%, m%: m = 4
Dim x%, Y%, k%
Range("d1").CurrentRegion.Offset(1, 0).Columns(1).ClearContents
r = Range("a1").CurrentRegion.Columns(1).Rows.Count
k = 2
Do Until k > r
    x = Application.CountIf(Cells(2, 1).Resize(r, 1), Cells(k, 1))
    Y = Application.CountIf(Cells(2, 4).Resize(k - 1, 1), Cells(k, 1))
       If x > 1 And Y = 0 Then
         Cells(m - 2, 4) = Cells(k, 1)
         m = m + 1
       End If
       k = k + 1
Loop
End Sub


انا اسلام استاذ سليم ركز biggrin2
ومشكور مرورك العطر ومشكور اثرائك للموضوع
ونصيحه حاول تبعد عن المنطق دا أغالى فى الكود
لانه مع البيانات الضخمه هيسبب بطئ شديد biggrin2
كما ان النتائج غير دقيقه
بمعنى أخر هيحصل أخطاء فى النتائج فى بعض الظروف جرب وشوف wink_3
تقبل وافر احترامى وتقديرى 81

أثارت هذه المشاركة إعجاب: salim، YasserKhalil،




10-10-2018 10:50 مساء
مشاهدة مشاركة منفردة [11]
salim
menu_open
خبير معتمد
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 22-08-2017
رقم العضوية : 43
المشاركات : 190
الجنس : ذكر
تاريخ الميلاد : 1-5-1989
يتابعهم : 13
يتابعونه : 6
قوة السمعة : 2081
الاعجاب : 427
 offline 
look/images/icons/i1.gif استخراج القيم المكررة فقط
اعتذر عن الخطأ في الاسم أستاذ إسلام
لقد قمت بتجربة الكود على 500 صف والنتائح دقيقة  وضعت عامود لحساب التكرار فلم اجد اي رقم يساوي 1
ارجو أعلامي اين يمكن للخطا ان يكون
الملف مرفق

 




لرؤية الروابط والمرفقات عليك الرد على الموضوع


أثارت هذه المشاركة إعجاب: YasserKhalil، Eslam Abdullah،




11-10-2018 01:15 صباحا
مشاهدة مشاركة منفردة [12]
Eslam Abdullah
menu_open
مشرف على لغات برمجة آخرى
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 03-10-2017
رقم العضوية : 852
المشاركات : 1158
الجنس : ذكر
تاريخ الميلاد : 1-9-1995
الدعوات : 2
يتابعهم : 3
يتابعونه : 55
قوة السمعة : 6904
الاعجاب : 1950
 offline 
look/images/icons/i1.gif استخراج القيم المكررة فقط
مشكور مساهماتك المميزه استاذ سليم
فقط احذف خلايا فى بداية او منتصف النطاق وتابع النتائج
وتترتب هذه النتائج لاعتماد الكود على تحديد النطاق باسلوب CurrentRegion

أثارت هذه المشاركة إعجاب: YasserKhalil، salim،





المواضيع المتشابهه
عنوان الموضوع الكاتب الردود الزوار آخر رد
استخراج القيم الفريدة وفق بيان محدد بالدالة المعرفة AlsaqrUnique Eslam Abdullah
12 1118 forsaan2003
استخراج البيانات واحضارها بصورة تقرير عبدالله فتحى
28 335 YasserKhalil
كيفية استخراج البيانات من قائمة منسدلة بكود vba emad eldwady
5 118 YasserKhalil
كيف جمع بعد دالة الصقر استخراج الارقام من النصوص رمضان بكري
6 122 YasserKhalil
كيفية استخراج الدالة Ahmed Samir
2 91 YasserKhalil

الكلمات الدلالية
استخراج ، القيم ، المكررة ،


 







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



الساعة الآن 06:49 مساء

أعلن هنا
أعلن هنا
أعلن هنا