أكاديمية الصقر للتدريب
(نسخة قابلة للطباعة من الموضوع)
https://excel-egy.com/forum/t2436
أنقر هنا لمشاهدة الموضوع بهيئته الأصلية

استخراج القيم المكررة فقط
Eslam Abdullah 10-10-2018 12:09 صباحا
السلام عليكم ورحمة الله وبركاته
أهلا ومرحبا بكم أخوانى الكرام موضوع اليوم هو تقديم حل لاحدى المشكلات


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

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
أكاديمية الصقر للتدريب

Powered by PBBoard ©Version 3.0.2