كود التفقيط باللغة الأنجليزية والعملة ريال سعودي

[saro0onh]

السلام عليكم

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

أستفدت منه كثير

الله يجزاكم الجنة 

 

حاولت أحل هذا الموضوع بنفسي ومن خلال الدروس بس ما قدرت

أنا مديرة مدرسة ونتعامل بالارقام بشكل كبير

وشي جديد عرفته من موقعكم كود التفقيط وعملت الموديل وضبط وكل شي تمام

بس حالياً لما أكتب الارقام تتحول لي إلى دولار وسنت

وأنا أبيها بالريال والهللة.

 

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

 

ممكن تسعدوني فيها الله يجزاكم خير

[جلال الجمال_ابو أدهم]

يرجى ارفاق الملف

[saro0onh]

أرفقت الكود في ملف تكست

SpellNumber.txt

[أبوعيد]

السلام عليكم

أوجه رسالتي إليك:

الرجاؤ تغيير اسم الظهور إلى اللغة العربية حتى تتفق مع قواعد الموقع

وإن أمكن الرجاء تغيير الصورة إلى ما يناسبها أو إلغاءها

لك كل الاحترام والتحية وأهلا وسهلا بك في هذا الصرح العلمي

تحياتي

[أحمد بكر]

مرفق الحل

ويمكن تعديل saudi riyal و halala 

Function SpellNumber(ByVal MyNumber, _
                  Optional pbNum As Boolean = True, _
                  Optional ptCur As String = "saudi riyal", _
                  Optional ptDec As String = "halala", _
                  Optional ptPlu As String = "")

Dim Curr, Decm, Temp
Dim DecimalPlace, Count
Dim vtPHolder As String

    ReDim Place(9) As String
    Place(2) = " Thousand "
    Place(3) = " Million "
    Place(4) = " Billion "
    Place(5) = " Trillion "

    '' String representation of amount
    MyNumber = Trim(Str(MyNumber))
 
    '' Position of decimal place 0 if none
    DecimalPlace = InStr(MyNumber, ".")
    '' Convert decimal part, and set MyNumber to currency amount
    If DecimalPlace > 0 Then
        vtPHolder = Left(Mid(MyNumber, DecimalPlace + 1) & "00", 2)
        If pbNum = True Then
            Decm = GetTens(vtPHolder)
        Else
            Decm = vtPHolder
        End If
        MyNumber = Trim(Left(MyNumber, DecimalPlace - 1))
    End If
 
    Count = 1
    Do While MyNumber <> ""
       Temp = GetHundreds(Right(MyNumber, 3))
       If Temp <> "" Then Curr = Temp & Place(Count) & Curr
          If Len(MyNumber) > 3 Then
             MyNumber = Left(MyNumber, Len(MyNumber) - 3)
        Else
            MyNumber = ""
        End If
        Count = Count + 1
    Loop
 
    Select Case Curr
        Case ""
            Curr = "No " & ptCur & ""
        Case "One"
            Curr = "One " & ptCur
        Case Else
            Curr = Curr & " " & ptCur & ""
    End Select
 
    Select Case Decm
        Case ""
            Decm = " No " & ptDec & ptPlu
        Case "One", "01"
            Decm = " and " & Decm & " " & ptDec
        Case Else
            Decm = " and " & Decm & " " & ptDec & ptPlu
    End Select
 
    SpellNumber = Curr & Decm
End Function
 
'*******************************************
' Converts a number from 100-999 into text *
'*******************************************
Function GetHundreds(ByVal MyNumber)
    Dim Result As String
 
    If Val(MyNumber) = 0 Then Exit Function
    MyNumber = Right("000" & MyNumber, 3)
 
    'Convert the hundreds place
    If Mid(MyNumber, 1, 1) <> "0" Then
        Result = GetDigit(Mid(MyNumber, 1, 1)) & " Hundred "
    End If
 
    'Convert the tens and ones place
    If Mid(MyNumber, 2, 1) <> "0" Then
        Result = Result & GetTens(Mid(MyNumber, 2))
    Else
        Result = Result & GetDigit(Mid(MyNumber, 3))
    End If
 
    GetHundreds = Result
End Function
 
'*********************************************
' Converts a number from 10 to 99 into text. *
'*********************************************
Function GetTens(TensText)
    Dim Result As String

    Result = ""                                         'null out the temporary function value
    If Val(Left(TensText, 1)) = 1 Then                  'If value between 10-19
        Select Case Val(TensText)
            Case 10: Result = "Ten"
            Case 11: Result = "Eleven"
            Case 12: Result = "Twelve"
            Case 13: Result = "Thirteen"
            Case 14: Result = "Fourteen"
            Case 15: Result = "Fifteen"
            Case 16: Result = "Sixteen"
            Case 17: Result = "Seventeen"
            Case 18: Result = "Eighteen"
            Case 19: Result = "Nineteen"
            Case Else
        End Select
      Else                                              'If value between 20-99
        Select Case Val(Left(TensText, 1))
            Case 2: Result = "Twenty "
            Case 3: Result = "Thirty "
            Case 4: Result = "Forty "
            Case 5: Result = "Fifty "
            Case 6: Result = "Sixty "
            Case 7: Result = "Seventy "
            Case 8: Result = "Eighty "
            Case 9: Result = "Ninety "
            Case Else
        End Select
         Result = Result & GetDigit(Right(TensText, 1)) 'Retrieve ones place
      End If
      GetTens = Result
End Function
 
'*******************************************
' Converts a number from 1 to 9 into text. *
'*******************************************
Function GetDigit(Digit)
    Select Case Val(Digit)
        Case 1: GetDigit = "One"
        Case 2: GetDigit = "Two"
        Case 3: GetDigit = "Three"
        Case 4: GetDigit = "Four"
        Case 5: GetDigit = "Five"
        Case 6: GetDigit = "Six"
        Case 7: GetDigit = "Seven"
        Case 8: GetDigit = "Eight"
        Case 9: GetDigit = "Nine"
        Case Else: GetDigit = ""
    End Select
End Function

تفقيط انجليزي.rar

تم تعديل أكتوبر 15, 2014 بواسطه أحمد بكر

[الصـقر]

الاخت الكريمة 

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

اتفضلى الملف به المطلوب

تفقيط.zip

تم تعديل أكتوبر 15, 2014 بواسطه حسام عيسى

[mmjksa]

الاخت الكريمة 

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

اتفضلى الملف به المطلوب

اخي العزيز بارك الله فيك

 

العربي يظهر عندى ملخبط ربش، كيف تعديله او تتكرم ترسل ملف معرب.

 

ولك خالص التحية

[الصـقر]

 

الاخت الكريمة 

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

اتفضلى الملف به المطلوب

اخي العزيز بارك الله فيك

 

العربي يظهر عندى ملخبط ربش، كيف تعديله او تتكرم ترسل ملف معرب.

 

ولك خالص التحية

 

اخى الكريم كود التفقيط يظهر الارقام بالعربى  ممكن توضح ما هى المشكله حتى اتمكن من مساعدتك

[saro0onh]

شكراً لك أستاذ أحمد

فعلاً الكود ضبط ويشتغل 100%

[saro0onh]

سؤال تقني

هل لازم أضيف المودل والكود في كل ملف أنشئة ؟

لاني لما فتحت ملف جديد لم يعمل إلى بعد إذافة الموديل والكود :(

[الصـقر]

اذا كان القصد ملف اكسل اخر نعم يجب نسخ الكود ووضعه فى ملف الجديد

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

[saro0onh]

بيكون الموضوع شغله شوية كل ملف جديد بعمله لازم أنسخ الكود 

أكيد فيه طريقة تثبت الكود بالبرنامج وأستغني عن نسخة كل شوية :(

[الصـقر]

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

لكن يمكن الكود ان يعمل على ملف الاكسيل بكل صفحات العمل بداخله هذا عادى

[anasbeirakdar]

سلامات

 

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

TL = Lira

Kr = Kurush

Bir bin bes yuz ve otuz kurush

تم تعديل سبتمبر 29, 2018 بواسطه anasbeirakdar

[Ali Mohamed Ali]

اهلا بك اخ كريم فى المنتدى

تفضل لك ما طلبت وجدت هذا الملف عندى

 

 

دالة التفقيط باللغة التركية.xlsm

او جرب هذا

 

 

turk.xlsm