الاحرف المكررة وغير المكررة

[mmm83]

السلام عليكم

لطفا اساتذة 

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

الاحرف المكررة وغير المكررة.xlsx

[أ / محمد صالح]

يمكنك استعمال هذا الكود بعد فك دمج الخلايا وتغيير الامتداد إلى xlsb حتى يقبل الأكواد 

Sub repchr()
Range("b6,b9").ClearContents
For n = 1 To Len([b3])
If UBound(Split([b3], Mid([b3], n, 1))) > 1 Then
[b6] = [b6] & IIf(InStr([b6], Mid([b3], n, 1)) = 0 And Mid([b3], n, 1) <> " ", IIf([b6] = "", "", "-") & Mid([b3], n, 1), "")
Else
[b9] = [b9] & IIf([b9] = "", "", "-") & Mid([b3], n, 1)
End If
Next n
MsgBox "Done by mr-mas.com"
End Sub

الكود يقوم بوضع الحروف المكررة في الخلية b6 والحروف غير المكررة في الخلية b9 اعتمادا على النص الموجود في الخلية b3

بالتوفيق

[lionheart]

Sub Test()
    [B6] = GetDupUniq([B3], True)
    [B9] = GetDupUniq([B3], False)
End Sub

Function GetDupUniq(ByVal txt As String, ByVal f As Boolean) As String
    Dim e, s As String, i As Long
    With CreateObject("Scripting.Dictionary")
        .CompareMode = 1
        For i = 1 To Len(txt)
            s = Mid$(txt, i, 1)
            If s <> " " Then .Item(s) = .Item(s) + 1
        Next i
        For Each e In .Keys
            If (f = True And .Item(e) = 1) Or (f = False And .Item(e) > 1) Then .Remove e
        Next e
        GetDupUniq = Join(.Keys, "-")
    End With
End Function

 

[mmm83]

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

[mmm83]

وللافاده وجدت هذا الكود الرائع للاستاذ سليم لحذف المكرر من الحروف

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