طريقة برمجة الحروف مع اﻷرقام في اﻹكسيل

[ياسر خليل أبو البراء]

جرب التعديل بهذا الشكل

Function CalcString(S As String)
    Dim ArrLetters, ArrValues, X() As Byte, SpaceCounter As Long
    Dim I As Long, Counter As Long, Pos&
    ArrLetters = Join(Array("أ", "ا", "إ", "ب", "ت", "ث", "ج", "ح", "خ", "د", "ذ", "ر", "ز", "س", "ش", "ص", "ض", "ط", "ظ", "ع", "غ", "ف", "ق", "ك", "ل", "م", "ن", "ه", "ة", "و", "ي"))
    ArrValues = Array(1, 1, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 26, 27, 28)
    X = StrConv(S, vbFromUnicode)
    For I = 0 To UBound(X)
        Pos = InStr(ArrLetters, Chr(X(I)))
        If Pos > 0 Then Counter = Counter + ArrValues((Pos - 1) / 2)
    Next I
    On Error Resume Next
    SpaceCounter = SpaceCount(S)
    If SpaceCounter = 0 Then
        CalcString = Counter
    Else
        CalcString = Counter - SpaceCounter
    End If
End Function

Function SpaceCount(ByVal strLine As String) As String
    Dim Str As String
    Dim TempCount As Long
    Dim I As Long
    
    Str = Trim(strLine)
    TempCount = 0
    
    For I = 1 To Len(Str)
        If Mid(Str, I, 1) = " " Then
            TempCount = TempCount + 1
        Else
            If TempCount > 0 Then
                SpaceCount = SpaceCount & " " & TempCount
                TempCount = 0
            End If
        End If
    Next I
    
    SpaceCount = Mid(SpaceCount, 2)
End Function

 

[قلم-الاكسل(عبدالعزيز)]

شكرا لك المهندس ابو البراء

قمت بنسخ ولصق الكود

لم يكتب في النتيجة 

value 

ما سبق

لكن كل ما اكتبه تظهر النتيجة صفر

[ياسر خليل أبو البراء]

الكود يعمل بشكل جيد معي

جرب الملف المرفق لربما حدث خطأ أثناء النسخ واللصق

 

Sum Letters YasserKhalil V2.rar

[قلم-الاكسل(عبدالعزيز)]

الكود يعمل بشكل جيد معي

جرب الملف المرفق لربما حدث خطأ أثناء النسخ واللصق

 

Sum Letters YasserKhalil V2.rar

مشكور عزيزي والله تعبتك معاي 

باركك الله في علمك وعملك ونفعك بك وحفظك من كل شر

قمت بتغيير واجهة الاكسل من الانجليزية للعربية 

ولكن دون جدوى

لما فتحته وكتبت كلمات اخرى  نفس المشكلة النتيجة صفر

لا عليك سيدي 

المشكلة ربما من جهازي وليست في الدالة او الملف المرفق 

 

[ياسر خليل أبو البراء]

أخي الكريم لا علاقة بواجهة الإكسيل ..أنا أعمل على نسخة أوفيس 2013 الإنجليزية وليست العربية وتعمل معي الدالة بكفاءة

ما هي نسخة الأوفيس لديك؟

هل هناك أي مشاكل بنسخة الأوفيس؟

لا تيأس وكرر المحاولة

ويرجى من الأخوة ممن جربوا الملف أن يوافونا بعمل الملف من عدمه معهم ..

[قلم-الاكسل(عبدالعزيز)]

المهندس ابو البراء اكتشفت الخطأ

لكن لا اعرف ما هو تصحيحه 

يعني لما اكتب مثلا 

بسم الله الرحمن الرحيم

يحسب الفراغات بين الكلمات 

حيث كتب في النتيجة 3

ولما اكتب كلمة واحدة لا يعطيني شيء

وكذلك لما كتبت كلمتين حسب الفراغ فقط واعطاني نتيحة 1 حيث ان الفراغ بين الكلمتين واحدhttp://dc20.arabsh.com/uploads/image/2015/10/02/0c3e424e66fa07.jpg

اي انه لا يحسب الحروف كما أنا أريده وكما برمجته سيادتك

فما هو الحل لهذه المشكلة 

أخي الكريم لا علاقة بواجهة الإكسيل ..أنا أعمل على نسخة أوفيس 2013 الإنجليزية وليست العربية وتعمل معي الدالة بكفاءة

ما هي نسخة الأوفيس لديك؟

هل هناك أي مشاكل بنسخة الأوفيس؟

لا تيأس وكرر المحاولة

ويرجى من الأخوة ممن جربوا الملف أن يوافونا بعمل الملف من عدمه معهم ..

نسخة الاوفيس لدي 2013 الانجليزية 

ليست لدي مشاكل بنسخة الاوفيس اطلاقا 

 

[ياسر خليل أبو البراء]

الملف يعمل معي بدون أي مشكلة وبنتائج صحيحة

ننتظر رأي الأخوة الذين جربوا الملف للتأكد من صحة الكود .. وسأحاول أن أقدم دالة أخرى ..

 

[قلم-الاكسل(عبدالعزيز)]

الملف يعمل معي بدون أي مشكلة وبنتائج صحيحة

ننتظر رأي الأخوة الذين جربوا الملف للتأكد من صحة الكود .. وسأحاول أن أقدم دالة أخرى ..

 

شكرا لك سيدنا العزيز ومهندسنا الجليل

 بارك الله فيك وفي عمرك 

واسف على اني اتعبتك معاي 

[ياسر خليل أبو البراء]

جرب الدالة التالية

Function YK(sInp As String) As Long
    Static bInit As Boolean
    Dim asMap() As String
    Dim asLtr() As String
    Dim I As Long
    Static aiVal(0 To 255) As Long

    If Not bInit Then
        asMap = Split("1 1 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 26 27 28")
        asLtr = Split("أ ا إ ب ت ث ج ح خ د ذ ر ز س ش ص ض ط ظ ع غ ف ق ك ل م ن ه ة و ي")
        For I = 0 To UBound(asMap)
            aiVal(Asc(asLtr(I))) = asMap(I)
        Next I
        bInit = True
    End If

    For I = 1 To Len(sInp)
        YK = YK + aiVal(Asc(Mid(sInp, I, 1)))
    Next I
End Function

 

Sum Letters YasserKhalil V3.rar

[قلم-الاكسل(عبدالعزيز)]

نجحت والحمد لله اولا واخيرا

نجحت والحمد لله اولا واخيرا

نجحت والحمد لله اولا واخيرا

وشكرا لك يا مبدع يا مهندس الابداع يا ابو براء يا ابوالهندسة كلها

حماك الله في حلك وترحالك وفي مشيك ونومك ويقظتك

وعفا عنك وغفر لك ولوالديك 

ووسع عليك واعطاك ما تتمنى في الدنيا والاخرة

 

"اشتغلت الدالة "

 

تم تعديل أكتوبر 2, 2015 بواسطه westexcel
تعديل

[ياسر خليل أبو البراء]

الحمد لله الذي بنعمته تتم الصالحات

جزيت خيراً على دعواتك الطيبة

تقبل تحياتي

[رمهان]

ماشاء الله عليك استاذ ياسر والى الامام

جميل جدا فكرتك استاذ سليم

هذه محاولة بسيطة وللاثراء والافادة ! ومغازلة الكبار!

Function ramhan(xinput As String) As Integer
xinput = Replace(xinput, "أ", "ا")
xinput = Replace(xinput, "إ", "ا")
xinput = Replace(xinput, "ة", "ه")
Dim xletters As String, i As Integer, xsum As Integer
xletters = "ابتثجحخدذرزسشصضطظعغفقكلمنهوي"
For i = 1 To Len(xinput)
xsum = xsum + InStr(1, xletters, mid(xinput, i, 1))
Next i
ramhan = xsum
End Function

تحياتي للجميع

[محمد حسن المحمد]

نجحت والحمد لله اولا واخيرا

نجحت والحمد لله اولا واخيرا

نجحت والحمد لله اولا واخيرا

وشكرا لك يا مبدع يا مهندس الابداع يا ابو براء يا ابوالهندسة كلها

حماك الله في حلك وترحالك وفي مشيك ونومك ويقظتك

وعفا عنك وغفر لك ولوالديك 

ووسع عليك واعطاك ما تتمنى في الدنيا والاخرة

 

"اشتغلت الدالة "

 

السلام عليكم أخي قلم الإكسل ...دعاء طيب لا أحسد أخي أبو البراء عليه ولكنني أرجو أن ينالنا شيء منه...

فالدال على الخير كفاعله.............تقبل تحياتي..

جرب الدالة التالية

Function YK(sInp As String) As Long
    Static bInit As Boolean
    Dim asMap() As String
    Dim asLtr() As String
    Dim I As Long
    Static aiVal(0 To 255) As Long

    If Not bInit Then
        asMap = Split("1 1 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 26 27 28")
        asLtr = Split("أ ا إ ب ت ث ج ح خ د ذ ر ز س ش ص ض ط ظ ع غ ف ق ك ل م ن ه ة و ي")
        For I = 0 To UBound(asMap)
            aiVal(Asc(asLtr(I))) = asMap(I)
        Next I
        bInit = True
    End If

    For I = 1 To Len(sInp)
        YK = YK + aiVal(Asc(Mid(sInp, I, 1)))
    Next I
End Function

 

Sum Letters YasserKhalil V3.rar

السلام عليكم أخي أبو البراء الحبيب...أعتقد أن دوالك وأكوادك لا تخضع للتجريب كونها من مصدر ثقة ووعي ودراسة وإتقان...جزاكم الله خيراً...

والحمد لله أن روح الدعابة وألقها بدا من خلال قبعتك التي لم ترفعها....ذلك يدعني أقول زاح شرك وزال همك وطاب عيشك بإذن الله...المحب لكم.

 

[قلم-الاكسل(عبدالعزيز)]

 

السلام عليكم أخي قلم الإكسل ...دعاء طيب لا أحسد أخي أبو البراء عليه ولكنني أرجو أن ينالنا شيء منه...

فالدال على الخير كفاعله.............تقبل تحياتي..

شكرا لك استاذي العزيز 

فعلا لو الله ثم انت بتوجيه رسالتي الى هنا ربما لن تحصل الفائدة الكبرى من مهندس المبدعين ابو البراء حفظه الله وبارك له في حياته

واعدو الله ان يجعلك مساعدا للمساكين مثلي

ويرحم بك عباده

ويبارك لك في رزقك وعمرك ويمنحك الصحة الابدية والحفظ الازلي من كل شر

شكرا مرة اخرى لمهندسنا الغالي ابو البراء

والله يوفقك في كل امورك ويسهل عليك حاجتك وتقضى بمجرد التفكر فيها

ونلتقي في موضوع اخر

[ياسر خليل أبو البراء]

أبي الحبيب أبو يوسف

دائماً ما تتفوق علينا بكلماتك الرقيقة الطيبة ..بارك الله فيك وجزيت خير الجزاء

أخي الحبيب المتميز المغازل رمهان

بصراحة أحلى غزل وأحلى دالة في الموضوع ..مشكور على المشاركة بهذه الدالة المميزة

الأخ الكريم قلم الإكسيل

الحمد لله أن تم المطلوب على خير ونورت المنتدى بين إخوانك وننتظر منك التواجد بيننا لنستفيد منك وتستفيد منا

تقبلوا تحياتي

[قلم-الاكسل(عبدالعزيز)]

ماشاء الله عليك استاذ ياسر والى الامام

جميل جدا فكرتك استاذ سليم

هذه محاولة بسيطة وللاثراء والافادة ! ومغازلة الكبار!

Function ramhan(xinput As String) As Integer
xinput = Replace(xinput, "أ", "ا")
xinput = Replace(xinput, "إ", "ا")
xinput = Replace(xinput, "ة", "ه")
Dim xletters As String, i As Integer, xsum As Integer
xletters = "ابتثجحخدذرزسشصضطظعغفقكلمنهوي"
For i = 1 To Len(xinput)
xsum = xsum + InStr(1, xletters, mid(xinput, i, 1))
Next i
ramhan = xsum
End Function

تحياتي للجميع

 

كمعلومة يا مهندس رمهان

لما مثلا اكتب

في الخلية

d2: كلمة الله

d3: النتيجة

في d3

ما هي المعادلة التي اكتبها كي استطيع مشاهدة النتيجة

يعني

d3

معتمدة على المكتوب في 

d2

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

d3

كي تظهر النتيجة وشكرا

مع انه المهندس ابو البراء حفظه الله من كل سوء ما قصر في الموضوع

لكن فقط كمعلومة نأخذها لأن الدالة التي شرحتها مختلفة عن ابو البراء 

[ياسر خليل أبو البراء]

=ramhan(d2)

 

[قلم-الاكسل(عبدالعزيز)]

=ramhan(d2)

 

شكرا لك استاذي الجليل

وبارك لك في عمرك والى الامام 

لا تنسانا من مواضيعك القيمة 

[رمهان]

أبي الحبيب أبو يوسف

دائماً ما تتفوق علينا بكلماتك الرقيقة الطيبة ..بارك الله فيك وجزيت خير الجزاء

أخي الحبيب المتميز المغازل رمهان

بصراحة أحلى غزل وأحلى دالة في الموضوع ..مشكور على المشاركة بهذه الدالة المميزة

الأخ الكريم قلم الإكسيل

الحمد لله أن تم المطلوب على خير ونورت المنتدى بين إخوانك وننتظر منك التواجد بيننا لنستفيد منك وتستفيد منا

تقبلوا تحياتي

كلامك ومرورك شرف واعجابك  وسام وما نحن الا قطره في بحر علمكم 

[عبد العزيز البسكري]

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

الأساتذة الأفاضل :

محمد حسن المحمد

ياسر خليل أبو البراء

رمهان

قلم الاكسل

بارك الله فيكم جميعًا .. جزاكم الله خيرًا و زادها بميزان حسناتكم .. موضوع مميّز و حوار شيّق بشكل رائع .. استفدنا منه الكثير

فائق احتراماتي

 

[جعفر الطريبق]

 

 

1	2	3	4	5	6	7	8	9	10	11	12	13	14	15	16	17	18	19	20	21	22	23	24	25	26	27	28	29	30	31	32	33	34	35	36
ء	آ	أ	ؤ	إ	ئ	ا	ب	ة	ت	ث	ج	ح	خ	د	ذ	ر	ز	س	ش	ص	ض	ط	ظ	ع	غ	ف	ق	ك	ل	م	ن	ه	و	ى	ي

 

السلام عليكم

يمكن تبسيط الكود باستغلال القيمة العددية للحروف :  ASCII

 لم أجرب الكود لأنه لأنني ضيعت سيدي الويندوز المطلوب عند محاولة تغيير اللغة عن طريق ال Regional Settings

Function AlphaSum(ByVal Word As String) As Long
    Dim i As Long
    Word = Replace(Word, " ", "")
    For i = 1 To Len(Word)
        AlphaSum = AlphaSum + Asc(Mid(Word, i, 1)) - IIf(Asc(Mid(Word, i, 1)) > &H63A, &H626, &H620)
    Next
End Function

 

تم تعديل أكتوبر 4, 2015 بواسطه جعفر الطريبق
أخد بعين الاعتبار Spaces

[محمد حسن المحمد]

السلام عليكم أستاذنا الكبير جعفر الطريبق المحترم

جزاكم الله خيراً...على هذه المساهمة الطيبة لإيجاد الحل المناسب...

لي رأي أعرضه على أساتذتي الأكارم: وهو تساؤل أعرضه على كل الأساتذة الأجلاء الذين ساهموا في هذا الموضوع كما يلي:

ألا تختلف قيم النتائج باختلاف عدد الأحرف ..وكذلك باختلاف موقع كل حرف ..حيث قام مجموعة منهم بالحساب على أساس 28 حرفاً .وقام القسم الآخربحسابها 36 حرفاً بالرجوع إلى طريقة كتابة كل حرف باعتباره حرفاً جديداً.

والمطلوب - فضلاً لا أمراً - الاتفاق على عدد الأحرف ...وترتيبها حسب موقعها بالنسبة للغات البرمجة لا باعتبار معرفتنا للترتيب الهجائي المعروف للجميع وكذلك طرح الفراغات التي تعتبر بمثابة حروف

جزاكم الله خيراً ...والشكر موصول لكم جميعاً ...لا تؤاخذوني على مداخلتي إن كان بها أي خطأ في التعبير باعتباري طالب مستجد في جامعتكم الكريمة الموقرة...والسلام عليكم.

[جعفر الطريبق]

الأستاد الفاضل محمد حسن المحمد

شكرا على الملاحظة القيمة ... أعتقد أن الحساب على أساس 28 أو 36 مرهون بارادة المستخدم  ... أنا أفضل الحساب على أساس 36 حرف لأنه أشمل  ASCII MAP

و نفس الأمر بالنسبة للفراغات فهو أمر مرتبط بما يريده طالب الكود أو المستخدم  ... يمكن تعديل الأكواد على حسب الرغبة و على حسب عدد الحروف المطلوبة

تم تعديل أكتوبر 4, 2015 بواسطه جعفر الطريبق

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

نعض التعديلات على الملف ليتجاهل كل شيئ غير مرغوب فيه   و  (يمكن الكتابه به اللغة الاجنبية)

/, . @ ,%, $ , "" ," " و غيره الكثير  (انظر الى الصفحة Letters)

مجموع حروف advanced.zip

تم تعديل أكتوبر 4, 2015 بواسطه سليم حاصبيا

[محمد حسن المحمد]

السلام عليكم

الشكر الجزيل للأستاذ جعفر الطريبق المحترم على إيضاحاته

شكرا على الملاحظة القيمة ... أعتقد أن الحساب على أساس 28 أو 36 مرهون بارادة المستخدم  ... أنا أفضل الحساب على أساس 36 حرف لأنه أشمل  ASCII MAP

و نفس الأمر بالنسبة للفراغات فهو أمر مرتبط بما يريده طالب الكود أو المستخدم  ... يمكن تعديل الأكواد على حسب الرغبة و على حسب عدد الحروف المطلوبة

كما أشكر الأستاذ الكريم سليم حاصبيا على معادلاته التي أظهر من خلالها مرونة

مع التعامل مع الأحرف العربية أو الأجنبية وتجاهل الأحرف ما لا نود إدراجه

بعض التعديلات على الملف ليتجاهل كل شيئ غير مرغوب فيه   و  (يمكن الكتابه به اللغة الاجنبية)

/, . @ ,%, $ , "" ," " و غيره الكثير  (انظر الى الصفحة Letters)

تقبلوا تحياتي العطرة..