ارجو التكرم واكمال كود تفقيط الدرجات لأكثر من ألف درجة

[الحضرمي2017]

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

ارجو التكرم ومساعدتي في زيادة تفقيط الدرجات لأكثر من الف في هذا الكود بالذات لأنه أعجبني لسهولته وسهولة كتابة الدالة أثناء التفقيط لكن ما يعيبه هو أنه لغاية 999 فقط وأنا اريد التفقيط لاكثر من 1200 درجة فياريت التكرم ومساعدتي بارك الله فيكم 

الملف هو هذا 

https://www.officena.net/ib/applications/core/interface/file/attachment.php?id=45988

 

[الحضرمي2017]

لو تكرمت اريد المساعدة

[ناصر سعيد]

Function n2t(d As Double) As String
m = Int(d / 100)
h = Int(d / 10) - (m * 10)
a = Int(d - (m * 100 + h * 10))
k = d - (m * 100 + h * 10 + a)
n2t = num((m), 3) & IIf(m > 0 And (a > 0 Or h > 0), " و ", "") & num((a), 1) & IIf(a > 0 And h > 1, " و ", " ") & num((h), 2)
n2t = Replace(n2t, "اثنتانِ عشرة", "اثنتا عشرة")
n2t = Replace(n2t, "ثمانمائة", "ثمنمائة")
n2t = Replace(n2t, "ثلاثمائة", "ثلثمائة")
n2t = Replace(n2t, "و  عشرة", "و عشر")
n2t = IIf(n2t = " عشرة", "عشر", n2t)
n2t = IIf(n2t = "مائتانِ ", "مائتا", n2t)
n2t = "فقط " & n2t & IIf(h = 0 And a = 2, "درجتانِ", IIf((h = 1 And a = 0) Or ((h = 0 And a > 2)), " درجاتٍ", IIf(h = 0 And a = 0, " درجةٍ", " درجةً"))) & IIf(k > 0, " و نصفٌ", "")
n2t = Replace(n2t, "  ", " ")
n2t = Replace(n2t, "إحدى درجةً", "درجةٌ")
n2t = Replace(n2t, "اثنتانِ درجتانِ", "درجتانِ")
End Function
Function num(n As Integer, t As Integer) As String
m = "مائة"
h = "ونَ"
Select Case n
Case Is = 1
num = IIf(t = 3, m, IIf(t = 2, "عشرة", "إحدى"))
Case Is = 2
num = IIf(t = 3, "مائتانِ", IIf(t = 2, "عشرونَ", "اثنتانِ"))
Case Is >= 3
num = IIf(t = 3, nn(n) & m, IIf(t = 2, nn(n) & h, nn(n)))
End Select
End Function
Function nn(n As Integer) As String
Select Case n
Case Is = 3
nn = "ثلاث"
Case Is = 4
nn = "أربع"
Case Is = 5
nn = "خمس"
Case Is = 6
nn = "ست"
Case Is = 7
nn = "سبع"
Case Is = 8
nn = "ثمان"
Case Is = 9
nn = "تسع"
End Select
End Function

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

[الحضرمي2017]

لو تكرمتم ارجو المساعدة محتاجه ضروري

17 ساعات مضت, ناصر سعيد said:

Function n2t(d As Double) As String
m = Int(d / 100)
h = Int(d / 10) - (m * 10)
a = Int(d - (m * 100 + h * 10))
k = d - (m * 100 + h * 10 + a)
n2t = num((m), 3) & IIf(m > 0 And (a > 0 Or h > 0), " و ", "") & num((a), 1) & IIf(a > 0 And h > 1, " و ", " ") & num((h), 2)
n2t = Replace(n2t, "اثنتانِ عشرة", "اثنتا عشرة")
n2t = Replace(n2t, "ثمانمائة", "ثمنمائة")
n2t = Replace(n2t, "ثلاثمائة", "ثلثمائة")
n2t = Replace(n2t, "و  عشرة", "و عشر")
n2t = IIf(n2t = " عشرة", "عشر", n2t)
n2t = IIf(n2t = "مائتانِ ", "مائتا", n2t)
n2t = "فقط " & n2t & IIf(h = 0 And a = 2, "درجتانِ", IIf((h = 1 And a = 0) Or ((h = 0 And a > 2)), " درجاتٍ", IIf(h = 0 And a = 0, " درجةٍ", " درجةً"))) & IIf(k > 0, " و نصفٌ", "")
n2t = Replace(n2t, "  ", " ")
n2t = Replace(n2t, "إحدى درجةً", "درجةٌ")
n2t = Replace(n2t, "اثنتانِ درجتانِ", "درجتانِ")
End Function
Function num(n As Integer, t As Integer) As String
m = "مائة"
h = "ونَ"
Select Case n
Case Is = 1
num = IIf(t = 3, m, IIf(t = 2, "عشرة", "إحدى"))
Case Is = 2
num = IIf(t = 3, "مائتانِ", IIf(t = 2, "عشرونَ", "اثنتانِ"))
Case Is >= 3
num = IIf(t = 3, nn(n) & m, IIf(t = 2, nn(n) & h, nn(n)))
End Select
End Function
Function nn(n As Integer) As String
Select Case n
Case Is = 3
nn = "ثلاث"
Case Is = 4
nn = "أربع"
Case Is = 5
nn = "خمس"
Case Is = 6
nn = "ست"
Case Is = 7
nn = "سبع"
Case Is = 8
nn = "ثمان"
Case Is = 9
nn = "تسع"
End Select
End Function

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

ياريت احد يساعد لو تكرمتم 

تم تعديل نوفمبر 26, 2017 بواسطه الحضرمي2017

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

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

عذرا لأني لم أنتبه أن هذا الموضوع بخصوص الكود الخاص بالتفقيط خاصتي

فالمنتدى مليء بالدرر

تفضل أخي الكريم

أصلح الله أحوالنا وأحوالكم في اليمن الشقيق

تفقيط الدرجات حتى 9999.5

ويمكن كتابة غ بدلا من الدرجة ويكون التفقيط غ ويمكن تعديله في الكود إلى أي كلمة أو عبارة

أحتاج دعاءكم لي بصلاح النفس وسعة الرزق

وفقنا الله وإياكم لكل خير

تفقيط الدرجات.zip

[الحضرمي2017]

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

تم تعديل نوفمبر 27, 2017 بواسطه الحضرمي2017

[ناصر سعيد]

'صمم بواسطة أ / محمد صالح 10/2/2011
'تم التعديل لإضافة الصفر والنصف 28/4/2015
'تم التعديل للوصول إلى 9999 والسماح بكتابة غ للغياب في 27/11/2017
' https://a1mas.com
Function n2t(d As String) As String
If d = "" Or d = "غ" Then
n2t = "غ"
ElseIf d = 0 Or d > 9999.5 Then
n2t = "لا شيء"
ElseIf d = 0.5 Then
n2t = "فقط نصف درجة"
Else
o = Int(d / 1000)
m = Int(d / 100) - (o * 10)
h = Int(d / 10) - (o * 100 + m * 10)
a = Int(d - (o * 1000 + m * 100 + h * 10))
k = d - (o * 1000 + m * 100 + h * 10 + a)
n2t = num((o), 4) & IIf(o > 0 And (a > 0 Or h > 0 Or m > 0), " و", "") & num((m), 3) & IIf(m > 0 And (a > 0 Or h > 0), " و", "") & num((a), 1) & IIf(a > 0 And h > 1, " و", " ") & num((h), 2)
n2t = Replace(n2t, "و ", "و")
n2t = Replace(n2t, "اثنتانِ عشرة", "اثنتا عشرة")
n2t = Replace(n2t, "وعشرة", "وعشر")
n2t = IIf(n2t = " عشرة", "عشر", n2t)
n2t = IIf(n2t = "مائتانِ ", "مائتا", n2t)
n2t = IIf(n2t = "ألفان ", "ألفا", n2t)
n2t = "فقط " & n2t & IIf(h = 0 And a = 2, "درجتانِ", IIf((h = 1 And a = 0) Or ((h = 0 And a > 2)), " درجاتٍ", IIf(h = 0 And a = 0, " درجةٍ", " درجةً"))) & IIf(k > 0, " ونصفٌ", "")
n2t = Replace(n2t, "إحدى  درجةً", "درجةٌ")
n2t = Replace(n2t, "اثنتانِ درجتانِ", "درجتانِ")
n2t = Replace(n2t, "مائتانِ  درجةٍ", "مائتا درجةٍ")
End If
n2t = Trim(n2t)
End Function
Function num(n As Integer, t As Integer) As String
o = "ة آلاف"
m = "مائة"
h = "ونَ"
Select Case n
Case Is = 1
num = IIf(t = 4, "ألف", IIf(t = 3, m, IIf(t = 2, "عشرة", "إحدى")))
Case Is = 2
num = IIf(t = 4, "ألفان", IIf(t = 3, "مائتانِ", IIf(t = 2, "عشرونَ", "اثنتانِ")))
Case Is >= 3
num = IIf(t = 4, nn(n) & o, IIf(t = 3, nn(n) & m, IIf(t = 2, nn(n) & h, nn(n))))
End Select
End Function
Function nn(n As Integer) As String
Select Case n
Case Is = 3
nn = "ثلاث"
Case Is = 4
nn = "أربع"
Case Is = 5
nn = "خمس"
Case Is = 6
nn = "ست"
Case Is = 7
nn = "سبع"
Case Is = 8
nn = "ثمان"
Case Is = 9
nn = "تسع"
End Select
End Function

الكود بعد التعديل للمحترم محمد صالح

رزقه الله الرزق الواسع ونحن معه 

وان يصلح الله حاله وحالنا ..

[Mohamed kalawa]

On 27/11/2017 at 8:39 PM, الحضرمي2017 said:

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

لو تكرمت اخى الكريم لا استطيع اضافة الكود  على اكسيل ٢٠١٦ فهو لا يلصق العربية 

لو تكرمت اخى الكريم لا استطيع اضافة الكود  على اكسيل ٢٠١٦ فهو لا يلصق العربية 

 

[الحضرمي2017]

في ٣‏/١‏/٢٠١٨ at 15:14, Mohamed kalawa said:

لو تكرمت اخى الكريم لا استطيع اضافة الكود  على اكسيل ٢٠١٦ فهو لا يلصق العربية 

لو تكرمت اخى الكريم لا استطيع اضافة الكود  على اكسيل ٢٠١٦ فهو لا يلصق العربية 

     بسيطة أخي الحبيب كل ماعليك هو تحويل اللغة العربية في الجهاز بالضغط على alt+shift  قبل النسخ وبعدها انسخ الكود ثم روح على الاكسل والصق ويضبط باذن الله حصلت معي وفعلت هكذا ونجح الامر

[Mohamed kalawa]

اخى هذا الملف فعلت ما تكرمت به والفقيط لم يظهر

1_1.rar

[الحضرمي2017]

تفضل أخي الحبيب فقد اضفت الكود لك والعفو على التاخير

1_1.rar