اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

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


saro0onh
إذهب إلى أفضل إجابة Solved by أحمد بكر,

الردود الموصى بها

السلام عليكم

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

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

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

 

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

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

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

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

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

 

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

 

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

رابط هذا التعليق
شارك

السلام عليكم

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

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

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

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

تحياتي

رابط هذا التعليق
شارك

  • أفضل إجابة

مرفق الحل

ويمكن تعديل 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

تم تعديل بواسطه أحمد بكر
  • Like 2
  • Thanks 1
رابط هذا التعليق
شارك

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

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

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

تفقيط.zip

تم تعديل بواسطه حسام عيسى
رابط هذا التعليق
شارك

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

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

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

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

 

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

 

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

رابط هذا التعليق
شارك

 

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

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

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

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

 

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

 

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

 

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

رابط هذا التعليق
شارك

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

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

رابط هذا التعليق
شارك

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

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

رابط هذا التعليق
شارك

  • 3 years later...
زائر
هذا الموضوع مغلق.
  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information