اريد ايجاد الأرقام المكررة مع عدد تكرارها لو تكرمتم

[وليد ابو عمر]

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

أعضاء المنتدى العظيم اوفيسنا الكرام

أرجو من سيادتكم التكرم بمساعدتي من خلال شيت الاكسل المرفوع بايجاد الارقام المكررة في العمود A وايجاد أيضا عدد التكرار لو مثلا رقم تكرر اكثر من مرة يتم اضافة امام الرقم عدد التكرار واستخراجهم منفردين بعيدا عن الارقام الغير مكررة وشكرا لكم

فلترة.rar

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

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

Option Explicit
Sub sorted_liste()
 Dim SL1 As Object
   Dim xItem
   Dim rg As Range, c As Range
   Dim i As Long
   Dim X As Long
   Dim arr()
   Dim y
   Range("c1").CurrentRegion.ClearContents
   Set SL1 = CreateObject("System.Collections.ArrayList")
   Set rg = Sheets("salim").Cells(1).CurrentRegion
   For Each c In rg
   y = SL1.Contains(c)
   X = Application.CountIf(rg, c)
     If X > 1 And y = False Then
     If Not SL1.Contains(c.Value) Then SL1.Add (c.Value)
     End If
     Next
    arr = SL1.ToArray
 Range("c1").Resize(UBound(arr) + 1) = Application.Transpose(arr)
End Sub

الملف مرفق

 

فلترة.xlsm

[Ali Mohamed Ali]

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

جعله الله فى ميزان حسناتك

[وليد ابو عمر]

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

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

Option Explicit
Sub sorted_liste()
 Dim SL1 As Object
   Dim xItem
   Dim rg As Range, c As Range
   Dim i As Long
   Dim X As Long
   Dim arr()
   Dim y
   Range("c1").CurrentRegion.ClearContents
   Set SL1 = CreateObject("System.Collections.ArrayList")
   Set rg = Sheets("salim").Cells(1).CurrentRegion
   For Each c In rg
   y = SL1.Contains(c)
   X = Application.CountIf(rg, c)
     If X > 1 And y = False Then
     If Not SL1.Contains(c.Value) Then SL1.Add (c.Value)
     End If
     Next
    arr = SL1.ToArray
 Range("c1").Resize(UBound(arr) + 1) = Application.Transpose(arr)
End Sub

الملف مرفق

 

فلترة.xlsm

بارك الله لك استاذي العزيز في هذا الكود الرائع ولكن هل من الممكن لو رقم تكرر أكثر من مرة أعرف كم مرة تكرر وشكرا لك

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

يلزم هذا التعديل على الكود

Option Explicit
Sub sorted_liste()
 Dim SL1 As Object
   Dim xItem
   Dim rg As Range, c As Range
   Dim i As Long
   Dim X As Long
   Dim arr()
   Dim y
   Range("c1").CurrentRegion.Offset(1).ClearContents
   Set SL1 = CreateObject("System.Collections.ArrayList")
   Set rg = Sheets("salim").Cells(1).CurrentRegion
   For Each c In rg
   y = SL1.Contains(c)
   X = Application.CountIf(rg, c)
     If X > 1 And y = False Then
     If Not SL1.Contains(c.Value) Then SL1.Add (c.Value)
     End If
     Next
    arr = SL1.ToArray
 With Range("c2").Resize(UBound(arr) + 1)
 .Value = Application.Transpose(arr)
 .Offset(, 1).Formula = "=COUNTIF($A$1:$A$500,C2)-1"
 .Offset(, 1).Value = .Offset(, 1).Value
 End With
End Sub

الملف

 

فلترة 1.xlsm

[Ali Mohamed Ali]

بارك الله فيك استاذ سليم تعديل ممتاز