كود لعد الحروف والارقام والعلامات فى الخلية

[MR.EXCEL]

لسلام عليكم

الرجاء كود لعد الحروف المتكررة فى الخلية الواحدة او الارقام او حتى العلامات الحسابية  على ان يعد كل حرف ورقم حتى ولو كان غير متكرر مثلا لو وجد حرف a مرة واحدة  يكتب رقم 1 وهكذا

ارجو ان اكون وضحت فكرتى

 

كما فى المثال المرفق

 

عدد الكلمات والحروف والارقام فى الخلية.rar

تم تعديل أغسطس 3, 2013 بواسطه MR.EXCEL

[طارق محمود]

السلام عليكم

أخي العزيز

إستخدم الكود التالي

 

Function cntt(myRng As String, x As String) As Integer
    y = 0
    For i = 1 To Len(myRng)
        If Mid(myRng, i, 1) = x Then y = y + 1
    Next
    cntt = y
End Function

لإنشاء دالة معرفة جديدة cntt

 

شاهد المرفق

 

عدد الكلمات والحروف والارقام فى الخلية.rar

[MR.EXCEL]

الله ينور استاذ طارق مبدع دائما

 

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

[عادل ابوزيد]

الباشمهندس طارق

دائماً اعمالك تحفة علمية جعلها الله فى ميزان حسناتك

[احب العلم]

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

أحسنت أستاذ طارق كود رائع 

[MR.EXCEL]

استاذ طارق لو امكن ان يكون العمل بالاكواد فقط بدون كتابة معادلات على اساس البيانات فى عمود A  والاحرف والارقام فى راس الصف الاول  وهم اجمالى 50 حرف ورقم وعلامة

 

لانى جربت المعادلة فاصبح الفايل ثقيل جدا

 

بارك الله فيك

[طارق محمود]

السلام عليكم

أخي العزيز

أنا فرضت 60 عمود (من 2 إلي 61)

يلزمك كودين

الكود الأول في حدث فتح الملف

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

Private Sub Workbook_Open()
Application.ScreenUpdating = False
Sheet1.Activate
For r = 2 To [A65536].End(xlUp).Row
     aa = Cells(r, 1).Value
     If IsEmpty(aa) Then GoTo 20
     
    For c = 2 To 61 ' columns
          x = Cells(1, c).Value
          If IsEmpty(x) Then GoTo 10
          y = 0
          
        For i = 1 To Len(aa)
                If Mid(aa, i, 1) = x Then y = y + 1
        Next
        Cells(r, c) = y
10      Next c
20  Next r
Application.ScreenUpdating = True
End Sub

والكود الثاني في حدث التغيير في العمود A

ليتحسس بعد تنفيذ الكود الأول أي تغير في العمود A ويعيد حساب هذا الصف فقط الذي حدث فيه تغيير في العمود A

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column <> 1 Or Target.Row = 1 Then Exit Sub


For c = 2 To 61 ' columns
      x = Cells(1, c).Value
      If IsEmpty(x) Then GoTo 10
      y = 0
      
    For i = 1 To Len(Target)
            If Mid(Target, i, 1) = x Then y = y + 1
    Next
    Cells(Target.Row, c) = y
10  Next c
    
End Sub

ولو أردت تغيير عدد الأعمدة من 60 إلي 50 مثلا فلتغير الرقم 61 إلي 51 في الكودين

For c = 2 To 61 ' columns

 

تفضل المرفق

عدد الكلمات والحروف والارقام فى الخلية2.rar

[MR.EXCEL]

الله ينور عليك والله العظيم كود ولا اروع

سوف ادعو لك فى الحرم ان شاء الله

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