اريد عمل جدول عائلة الكلمات في اللغة الانجليزية

[علي الهتاري]

 

عيدكم مبارك

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

وشكراً

EN1.xlsx

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

اذا كان ما فهمته صحيحاً هذا الكود (فقط اضغط الزر Run)

Option Explicit
Sub Creezy_sort()
 Dim CoL As Object
 Dim Lr%, i%, x%
 Dim arr
 Dim Ws As Worksheet
 Set Ws = Sheets("EN")
 
 With Ws
    .Range("E1").CurrentRegion.Offset(1).ClearContents
    Set CoL = CreateObject("System.Collections.sortedlist")
    Lr = .Cells(Rows.Count, 1).End(3).Row
    For i = 2 To Lr
       CoL.Add Len(.Cells(i, 1)) + i / 1000, .Cells(i, 1) & _
       "*" & .Cells(i, 2)
     Next i
     x = 2
     For i = 0 To CoL.Count - 1
     .Cells(x, "E") = Split(CoL.GetByIndex(i), "*")(0)
     .Cells(x, "F") = Split(CoL.GetByIndex(i), "*")(1)
      arr = Split(Split(CoL.GetByIndex(i), "*")(1), ",")
     .Cells(x, "G") = UBound(arr) + 1
      x = x + 1
     Next
End With
Set Ws = Nothing: Set CoL = Nothing
End Sub

الملف مرفق

Hitari.xlsm

[علي الهتاري]

شكراً استاذ سليم 

حاولت اشغل الكود يعطيني رسالة

out of memory

بحثت عن حل للمشكلة وماوصلت لنتيجة

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

لا أعرف ما المشكلة عندك (ربما اصدار الااوفيس قديم)

عندي يعمل بشكل جيد (الصورة)

[هانى محمد]

أحسنت استاذ سليم عمل ممتاز الكود يعمل بكل كفاءة ولا يوجد به اى مشكلة بالفعل وتم تجربته

علي الهتاري كما أخبرك استاذنا الكبير سليم حاصبيا فالملف يعمل بكل كفاءة فإن كان هناك مشكلة لديك فمن عندك فربما تكون بالفعل نسخة الأوفيس عندك أقدم من 2010 كما اخبرك استاذنا الكريم فعليك بتحديث الأوفيس لديك وشكرا ... عليك وضع هذه المعادلة بداية من الخلية C2 سحباً للأسفل

=LEN(B2)-LEN(SUBSTITUTE(B2,",",""))+1

Hitari.xlsm

[علي الهتاري]

الحمدلله شغلت الملف في لابتوب اخر 

والكود شغال اكثر من رائع

الخلل من جهازي ماعرفت السبب

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