أكاديمية الصقر للتدريب
موضوع بعنوان :استخراج القيم المكررة فقط
الكاتب :Eslam Abdullah


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


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

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