حذف المكرر في الخلية الواحدة

[كريم الامين]

الاخوة الافاضل الكرام 

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

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

لدي خلية فيها اسم احمد محمد ياسين

المطلوب اولا حذف جميع الاحرف المكررة

ثانيا 

حذف المكرر والابقاء على حرف واحد من التكرار 

مثلا لو كان حرف أ مكرر ثلاث مرات 

احذف حرفين وابقي واحد

مع جزيل الشكر لكل الاخوة 

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

حيث انك لم ترفع ملف للمعاينة اليك هذا النموذج مع صورو عن التنتيجة

1-الاسماء في العامود B
2- عدد الحرف المطلوبة في العامود A
3- المعادلات في النطاق من C2  الىAF26

المعادلات  في العامود A

=IF($B2="","",SUM(IF(FREQUENCY(MATCH(MID(TRIM(SUBSTITUTE($B2," ","")),ROW(INDIRECT("1:"&LEN(TRIM(SUBSTITUTE($B2," ",""))))),1),MID(TRIM(SUBSTITUTE($B2," ","")),ROW(INDIRECT("1:"&LEN(TRIM(SUBSTITUTE($B2," ",""))))),1),0),MATCH(MID(TRIM(SUBSTITUTE($B2," ","")),ROW(INDIRECT("1:"&LEN(TRIM(SUBSTITUTE($B2," ",""))))),1),MID(TRIM(SUBSTITUTE($B2," ","")),ROW(INDIRECT("1:"&LEN(TRIM(SUBSTITUTE($B2," ",""))))),1),0)),1,0)))

في النطاق من C2  الى AF26

=IF(OR(COLUMNS($A$2:A2)>$A2,$A2=""),"",MID(SUBSTITUTE(TRIM($B2)," ",""),SMALL(IF(FREQUENCY(MATCH(MID(TRIM(SUBSTITUTE($B2," ","")),ROW(INDIRECT("1:"&LEN(TRIM(SUBSTITUTE($B2," ",""))))),1),MID(TRIM(SUBSTITUTE($B2," ","")),ROW(INDIRECT("1:"&LEN(TRIM(SUBSTITUTE($B2," ",""))))),1),0),MATCH(MID(TRIM(SUBSTITUTE($B2," ","")),ROW(INDIRECT("1:"&LEN(TRIM(SUBSTITUTE($B2," ",""))))),1),MID(TRIM(SUBSTITUTE($B2," ","")),ROW(INDIRECT("1:"&LEN(TRIM(SUBSTITUTE($B2," ",""))))),1),0)),ROW(INDIRECT("1:"&LEN(TRIM(SUBSTITUTE($B2," ","")))))),COLUMNS($A$2:A2)),1))

صورة عن الملف

الملف مرفق

KARIM.xlsx

[كريم الامين]

شكرا لكم استاذنا الفاضل السباق دائما للمساعد ومنكم تعلمنا الكثير

ولكن ارجو من جنابكم الطيب الاطلاع على الملف المرفق 

وهل من الممكن ان تكون الحروف المكررة في خلية واحد فقط؟

حذف المكرر.xlsx

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

كان من المفروض تحميل ملف مع شرح المطلوب  بدقة (كما اقترح الاستاذ هاني محمد)

ولا لزوم لتضييع اكثر من ساعة من الوقت على كتابة معادلات وفي الأخير تظهر انها ليست المطلوبة

لذا كنت أريد الاعتذار عن المتابعة بهذا الملف

لكن حيث انها المرة الاولى لا بد من الاستجابة

الكود

Option Explicit

Function Salim_Letter(rg As Range)
Dim dic As Object, i
Dim ST, Mot$
 Mot = Replace(rg.Value, " ", "")
Set dic = CreateObject("Scripting.Dictionary")

 For i = 1 To Len(Mot)
   If Not dic.Exists(Mid(Mot, i, 1)) Then
    dic(Mid(Mot, i, 1)) = dic.Count
   End If
 Next i
  If dic.Count Then
    ST = Join(dic.keys, " ")
  Else
    ST = vbNullString
  End If
  Salim_Letter = ST
End Function

جرب هذا الملف

Remove_duplicate_letters.xlsm

[كريم الامين]

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

[TQTHAMI]

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

كل عام وانتم بخير 

مثال رائع وحله من استاذ رائع 

ولي طلب اذا امكن ابي نفس الملف ولكن بدون حذف الحروف المكرره مثال   طلال    ط ل ا ل  كل حرف في حقل 

ts.xlsm

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

تفضل با ضديقي  TQTHAMI و عيد سعيد 

 

TQTHAMI.xlsm

[TQTHAMI]

لايسعني الا ان اشكرك بما قالة الرسول صلى الله عليه وسلم 

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

فهي كافيه لكل معاني الشكر 

وتقبل تحياتي 

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

اذا كان تم تم المطلوب اضغط افضل اجابة لاغلاقه ولا تنس الضغط على اعجاب ايضاً