حصر الاعداد التى تكررت اكثر من 10 وعدد تكرارها

[۩◊۩ أبو حنين ۩◊۩]

السلام عليكم

** ارجو المساعده فى تحديد الاقام التى تكررت اكثر من 10 مرات فى عمود c  وتحديد عدد تكرارها

*** لا استطيع رفع الملف لمشكله فى النت

تقبلوا وافر تحياتى

**

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

جرب هذا الملف

TEKRAR COUNT.rar

[۩◊۩ أبو حنين ۩◊۩]

السلام عليكم

اخى الحبيب سليم ... جزاك الله كل الخير

حل ممبدع الا انى لا استطبيع زياده الرنج الى 3000

... هل يمكن عمل الرنح كل الخلايا التى بها بيانات فى العمود a

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

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

6 دقائق مضت, ۩◊۩ أبو حنين ۩◊۩ said:

السلام عليكم

اخى الحبيب سليم ... جزاك الله كل الخير

حل ممبدع الا انى لا استطبيع زياده الرنج الى 3000

... هل يمكن عمل الرنح كل الخلايا التى بها بيانات فى العمود a

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

جرب هذا الملف

بالنسبة الى هذا العدد الكبير يمكن الحل عن طريق الكود

[۩◊۩ أبو حنين ۩◊۩]

 

3 دقائق مضت, سليم حاصبيا said:

جرب هذا الملف

بالنسبة الى هذا العدد الكبير يمكن الحل عن طريق الكود

الا يمكن ان نجعل البحث فى الخلايا التى بها بيانات فى العمود  a

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

جرب هذا الماكرو

Sub TekrarList()
Application.ScreenUpdating = False
Dim x As Long
Dim dictionary As Object
Dim my_rg As Range

Set dictionary = CreateObject("scripting.dictionary")
Set my_rg = ActiveSheet.Range(Range("A1"), Range("A1").End(xlDown))
ActiveSheet.Range("b:d").ClearContents
Range("b1") = "العناصر المكررة": Range("c1") = "التكرار": Range("d1") = "عدد العناصر المكررة"

On Error Resume Next
For i = 1 To my_rg.Count
x = Application.CountIf(my_rg, my_rg.Cells(i))
If x >= 10 Then
dictionary.Add my_rg.Cells(i).Value, 1
End If
Next

Sheets(1).Range("d2") = dictionary.Count
Sheets(1).Range("b2").Resize(dictionary.Count).Value = _
Application.Transpose(dictionary.keys)
    For m = 1 To dictionary.Count
      ActiveSheet.Cells(m + 1, 3) = Application.CountIf(my_rg, ActiveSheet.Cells(m + 1, 2))
    Next
Application.ScreenUpdating = True


End Sub

 

[حسين مامون]

2 ساعات مضت, سليم حاصبيا said:

جرب هذا الماكرو

Sub TekrarList()
Application.ScreenUpdating = False
Dim x As Long
Dim dictionary As Object
Dim my_rg As Range

Set dictionary = CreateObject("scripting.dictionary")
Set my_rg = ActiveSheet.Range(Range("A1"), Range("A1").End(xlDown))
ActiveSheet.Range("b:d").ClearContents
Range("b1") = "العناصر المكررة": Range("c1") = "التكرار": Range("d1") = "عدد العناصر المكررة"

On Error Resume Next
For i = 1 To my_rg.Count
x = Application.CountIf(my_rg, my_rg.Cells(i))
If x >= 10 Then
dictionary.Add my_rg.Cells(i).Value, 1
End If
Next

Sheets(1).Range("d2") = dictionary.Count
Sheets(1).Range("b2").Resize(dictionary.Count).Value = _
Application.Transpose(dictionary.keys)
    For m = 1 To dictionary.Count
      ActiveSheet.Cells(m + 1, 3) = Application.CountIf(my_rg, ActiveSheet.Cells(m + 1, 2))
    Next
Application.ScreenUpdating = True


End Sub

 

كود رائع تشكر استاد سليم حاصبيا

[۩◊۩ أبو حنين ۩◊۩]

السلام عليكم

الاخ الجليل سليم

جزاك الله كل الخير والتقدير

كود رائع رائع ... والاضافه " عدد العناصر المكررة " ممتاز

هل يمكن تبديل القيمه 10 الى قيمه خليه ولتكن  F1

 

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

تم تعديل يناير 6, 2017 بواسطه ۩◊۩ أبو حنين ۩◊۩

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

استبدل الى هذا الماكرو

Sub TekrarList_With_choise()
Application.ScreenUpdating = False
Dim x As Long
Dim dictionary As Object
Dim my_rg As Range
Dim My_number As Integer
My_number = ActiveSheet.[f1]
 If Not IsNumeric(My_number) Or My_number <= 0 Then
 Exit Sub
 Else
 My_number = Int(My_number)
  End If
  If My_number = 0 Then My_number = 1
Set dictionary = CreateObject("scripting.dictionary")
Set my_rg = ActiveSheet.Range(Range("A1"), Range("A1").End(xlDown))
ActiveSheet.Range("b:d").ClearContents
Range("b1") = "العناصر المكررة": Range("c1") = "التكرار": Range("d1") = "عدد العناصر المكررة"

On Error Resume Next
For i = 1 To my_rg.Count
x = Application.CountIf(my_rg, my_rg.Cells(i))
  If My_number >= my_rg.Count Then Exit Sub
If x >= My_number Then
dictionary.Add my_rg.Cells(i).Value, 1
End If
Next

Sheets(1).Range("d2") = dictionary.Count
Sheets(1).Range("b2").Resize(dictionary.Count).Value = _
Application.Transpose(dictionary.keys)
    For m = 1 To dictionary.Count
      ActiveSheet.Cells(m + 1, 3) = Application.CountIf(my_rg, ActiveSheet.Cells(m + 1, 2))
    Next
Application.ScreenUpdating = True


End Sub

 

[۩◊۩ أبو حنين ۩◊۩]

السلام عليكم

الاخ الجليل سليم

جزاك الله كل الخير والتقدير

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

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

وعليكم السلام

إثراءً للموضوع جرب الكود التالي

Sub Test()
    Dim curRow          As Long
    Dim col             As New Collection
    Dim itm             As Variant
    Dim cnt             As Long
    Dim rng             As Range
    Dim cel             As Range
    
    Const firstRow      As Integer = 1      'رقم صف البداية
    Const dataCol       As Integer = 1      'رقم العمود مصدر البيانات
    Const extractCol    As Integer = 8      'رقم العمود للنتائج المطلوبة
    
    Application.ScreenUpdating = False
        Set rng = Range(Cells(firstRow, dataCol), Cells(Rows.Count, dataCol).End(xlUp))
        On Error Resume Next
            For Each cel In rng
                col.Add Item:=cel.Value, Key:=CStr(cel.Value)
            Next cel
        On Error GoTo 0
        
        curRow = firstRow
        For Each itm In col
            cnt = Application.CountIf(rng, itm)
            If cnt > 10 Then              'عدد مرات التكرار
                Cells(curRow, extractCol).Value = itm
                Cells(curRow, extractCol + 1).Value = cnt
                curRow = curRow + 1
            End If
        Next itm
    Application.ScreenUpdating = True
End Sub

 

[۩◊۩ أبو حنين ۩◊۩]

السلام عليكم

اخى ياسر جزاك الله كل الخير  وكل التقدير

دائما ما تضيف كل جديد

وارجو ..... إيجاد حل عن طريق المعادلات 

هل ذلك متاح

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

وعليكم السلام

أعتقد أن الأخ سليم قدم حل ممتاز بالمعادلات .. 

[۩◊۩ أبو حنين ۩◊۩]

السلام عليكم

اخى العزيز ياسر .. فعلا الاخ الكريم سليم .. قدم حل ممتاز عن طريق المعادلة ... جزاه الله كلالخير والتقدير

الا انى لا استطيع زياده الرنج فى المعادله ...من 30 الى 50000

كما ان العمود لو احتوى حروف .. مثل A5   لا تظهر اى نتيجه

اخى الحبيب لدى استفسار فى الكود الذى اضفته

اريد ان يكون مصدر البيانات التى سيتم التعامل معها ( شيت عام )

وتكون النتيجه المطلوبه فى شيت (حصر التعديلات )

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

كيف ذلك

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

 

 

تم تعديل يناير 7, 2017 بواسطه ۩◊۩ أبو حنين ۩◊۩

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

وعليكم السلام

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

[۩◊۩ أبو حنين ۩◊۩]

السلام عليكم

اخى الحبيب ياسر

مرفق الملف المراد العمل عليه

تعزر رفع الملف الى الموقع ...

http://www.flflh.com/download-86856-حصر

الخليه E3 فى شيت حصر التعديلات تحدد عدد مرات التكرار

الخليه C2  و  D2  الفترة المراد عمل الحصر بينها على اساس العمود E  فى شيت عام

ارجو ان يكون الشرح وافى

تقبل وافر تحياتى

 

 

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

وعليكم السلام

الملف غير موجود حاول رفعه على سيرفر المنتدى بعد ضغطه

 

* هناك نقطة جديدة لم تذكرها من قبل ..

الخليه C2  و  D2  الفترة المراد عمل الحصر بينها على اساس العمود E  فى شيت عام  (هل في الخلايا تواريخ ؟؟!!) ولما لم تذكر من البداية كافة التفاصيل ..

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

انظر الى المرفق

يمكن استخراج التكرار حسب ما تريد (نص أو أرقام)

لتعمل المعادلة بعد نسخها على العدد الكبير (5000 صف) يجب توسيع النطاق الى A5000  مع استعمال (Ctrl+Shift+enter)للمعادلة لانها معادلة صفيف

الحل في الصفحة Salim من المرفق

TEKRAR COUNT 1.rar

[ابو الياس نبيل جمعان]

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

لم اعرف كيف اتواصل معك للمساعدة في طلبي الذي وضعته على الرابط 

ارجو المساعدة 

الرابط

 

[۩◊۩ أبو حنين ۩◊۩]

في ‏07 ‏يناير, ‏2017 at 18:30, سليم حاصبيا said:

انظر الى المرفق

يمكن استخراج التكرار حسب ما تريد (نص أو أرقام)

لتعمل المعادلة بعد نسخها على العدد الكبير (5000 صف) يجب توسيع النطاق الى A5000  مع استعمال (Ctrl+Shift+enter)للمعادلة لانها معادلة صفيف

الحل في الصفحة Salim من المرفق

TEKRAR COUNT 1.rar

السلام عليكم

جزاك الله خيرا اخى العزيز سليم

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

المعادله هى المطلوبه فهلا ... وبعد تطبيقها  ... تم الامر بشكل ممتاذ ...

وكما ذكرت من قبل ... الرنج الكبير بيثقل الملف جدا ....

جزاك الله كل الخير على تعبك ووقت معى

سلمت يداك بكل خير