تفقيط الارقام باللغة العربية Excel و اللغه الانجليزيه

تفقيط الارقام باللغة العربية Excel

تفقيط الارقام باللغة العربية Excel تحويل الرقم الى نص بالعربي نقدم لكم اليوم داله سبق و ان عرضنها و هي داله التفقيط لكن نعرض اليوم تحديثات جديده لهذه الداله و التي تستطيع تفقيط الارقام بما في ذلك الكسور اي الارقام العشريه حتي ثلاث ارقام

حيث ان داله التي سبق و ان عرضها كانت تقوم بالتفقيط حتي رقمين عشريين و بالتالي كانت غير عمليه مع بعض العملات العربيه مثل الدينار الكويتي و الذي يحتاج  ثلاث كسور عشريه

تفقيط

التفقيط باللغة العربية Excel هي عمليه تحويل من الشكل الرقمي المتعارف عليه الي شكل كلمات بالشكل النصي

داله التفقيط

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

دالة تفقيط عربية تصلح لكل العملات

مميزات هذه الداله

التفقيط باللغه العربيه بشكل مميز مع مراعه قواعد اللغه العربيه ( دالة تفقيط عربية تصلح لكل العملات )

يمكن تعديل الداله لتباسب اي عمله محليه ريال سعودي  , دينار كويتي , جنيه مصري دولار اي عمله محليه او اجنبيه اخري

تفقيط باللغة العربية Excel

يمكن استخدام الكود في الاكسيل او الاكسيس او بعض لغات البرمجه الاخري المعتمده علي vb

 

لتحميل ملف دالة تفقيط الارقام باللغة العربية Excel هنا

للداله التفقيط باللغه الانجليزيه

= SpellNumber(22.50)

Option Explicit
' هذا الكود من صفحه الدعم العربي لموقع مايكروسوفت 
Function SpellNumber(ByVal MyNumber)

Dim Dollars, Cents, Temp
Dim DecimalPlace, Count
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 cents and set MyNumber to dollar amount.

If DecimalPlace > 0 Then

Cents = GetTens(Left(Mid(MyNumber, DecimalPlace + 1) & _ "00", 2))

MyNumber = Trim(Left(MyNumber, DecimalPlace - 1))

End If

Count = 1

Do While MyNumber <> ""

Temp = GetHundreds(Right(MyNumber, 3))

If Temp <> "" Then Dollars = Temp & Place(Count) & Dollars

If Len(MyNumber) > 3 Then

MyNumber = Left(MyNumber, Len(MyNumber) - 3)

Else

MyNumber = ""

End If

Count = Count + 1

Loop

Select Case Dollars

Case ""

Dollars = "No Dollars"

Case "One"

Dollars = "One Dollar"

Case Else

Dollars = Dollars & " Dollars"

End Select

Select Case Cents

Case ""

Cents = " and No Cents"

Case "One"

Cents = " and One Cent"

Case Else

Cents = " and " & Cents & " Cents"

End Select

SpellNumber = Dollars & Cents

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

تفقيط الارقام باللغة العربية Excel

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

'www.acc-arab.com
'هذا المحتوي خاص بموقع المحاسب العربي
'بالنسبه الي هذا الكود يفضل تحميله من الملف المرفق حيث ان في هذا العرض الحالي حروف اللغه العربيه غير دقيقه 

Function lireCentaine(ByVal Montant As Double) As String
Dim ChiffreLettre
Dim Centaine As Double
Dim Dizaine As Double
Dim T As String
Dim Chaine As String
ChiffreLettre = Array("æÇÍÏ", "ÇËäÇä", "ËáÇËÉ", "ÃÑÈÚÉ", "ÎãÓÉ", "ÓÊÉ", "ÓÈÚÉ", "ËãÇäíÉ", "ÊÓÚÉ", "ÚÔÑÉ", "ÅÍÏì ÚÔÑ", "ÇËäí ÚÔÑ", "ËáÇËÉ ÚÔÑ", "ÃÑÈÚÉ ÚÔÑ", "ÎãÓÉ ÚÔÑ", "ÓÊÉ ÚÔÑ", "ÓÈÚÉ ÚÔÑ", "ËãÇäíÉ ÚÔÑ", "ÊÓÚÉ ÚÔÑ")
Centaine = Int(Montant / 100)
Select Case Centaine
Case 0
    Chaine = ""
Case 1
        Chaine = "ãÇÆÉ"
Case 2
        Chaine = "ãÇÆÊÇä"
Case 3
        Chaine = "ËáÇËãÇÆÉ"
Case 4
        Chaine = "ÃÑÈÚãÇÆÉ"
Case 5
        Chaine = "ÎãÓãÇÆÉ"
Case 6
        Chaine = "ÓÊãÇÆÉ"
Case 7
        Chaine = "ÓÈÚãÇÆÉ"
Case 8
        Chaine = "ËãÇäãÇÆÉ"
Case 9
        Chaine = "ÊÓÚãÇÆÉ"
End Select
Dizaine = Modulo(Montant, 100)
Select Case Dizaine
    Case 0
        T = ""
    Case 1 To 19
        T = ChiffreLettre(Dizaine - 1)
    Case 20
        T = " ÚÔÑæä"
    Case 21 To 29
        T = ChiffreLettre(Dizaine - 21) & " æÚÔÑæä"
    Case 30
        T = " 臂辊"
    Case 31 To 39
        T = ChiffreLettre(Dizaine - 31) & " æËáÇËæä"
    Case 40
        T = " ÃÑÈÚæä"
    Case 41 To 49
        T = ChiffreLettre(Dizaine - 41) & " æÃÑÈÚæä"
    Case 50
        T = " ÎãÓæä"
    Case 51 To 59
        T = ChiffreLettre(Dizaine - 51) & " æÎãÓæä"
    Case 60
        T = " ÓÊæä"
    Case 61 To 69
        T = ChiffreLettre(Dizaine - 61) & " æÓÊæä"
    Case 70
        T = " ÓÈÚæä"
    Case 71 To 79
        T = ChiffreLettre(Dizaine - 71) & " æÓÈÚæä"
    Case 80
        T = " ËãÇäæä"
    Case 81 To 89
        T = ChiffreLettre(Dizaine - 81) & " æËãÇäæä"
    Case 90
        T = " ÊÓÚæä"
    Case 90 To 99
        T = ChiffreLettre(Dizaine - 91) & " æÊÓÚæä"
    Case Else
        T = "Erreur de conversion !"
End Select
If Chaine <> "" Then
   If (T <> "") Then
   Chaine = Chaine
   T = " æ" & T
   End If
   End If
   If Chaine = "" Then
   If (T <> "") Then
   Chaine = Chaine
   T = T
   End If
   End If
If (Chaine & " " & T) = " " Then
    lireCentaine = ""
Else
    lireCentaine = LTrim(Chaine & " ") & T
End If
End Function
Function Modulo(ByVal Nombre As Double, ByVal Diviseur As Double) As Double
    Modulo = Nombre - (Diviseur * Int(Nombre / Diviseur))
End Function
Function Arrondir(ByVal ValeurArrondi As Double, ByVal NbreDeci As Integer) As Double
    Arrondir = ValeurArrondi + (5 * 10 ^ -(NbreDeci + 1))
    Arrondir = Int(Arrondir * 10 ^ NbreDeci) / 10 ^ NbreDeci
End Function
Function NombreToArabe(ByVal Total As Double) As String
    Dim Millions As Double
    Dim Milliers As Double
    Dim cent As Double
    Dim decimales As Double
    Dim T0 As String
    Dim T1 As String
    Dim T2 As String
    Dim T3 As String
    Dim Resultat As String
    Dim T As String
    Total = Arrondir(Total, 3)
    Millions = Int(Modulo(Int(Total / 1000000), 1000))
    Milliers = Int(Modulo(Int(Total / 1000), 1000))
    cent = Int(Modulo(Total, 1000))
    decimales = Arrondir((Modulo(Total * 1000, 1000)), 1)
    
    T0 = lireCentaine(Millions)
    T1 = lireCentaine(Milliers)
    T2 = lireCentaine(cent)
    T3 = lireCentaine(decimales)
   If T0 <> "" Then
   If (T1 <> "") Then
   If (T2 <> "") Then
   T0 = T0
   T1 = " æ" & T1
   T2 = " æ" & T2
   End If
   End If
   End If
   If T0 = "" Then
   If (T1 <> "") Then
   If (T2 <> "") Then
   T0 = T0
   T1 = T1
   T2 = " æ" & T2
   End If
   End If
   End If
   If T0 <> "" Then
   If (T1 <> "") Then
   If (T2 = "") Then
   T0 = T0
   T1 = " æ" & T1
   T2 = T2
   End If
   End If
   End If
   If T0 = "" Then
   If (T1 <> "") Then
   If (T2 = "") Then
   T0 = T0
   T1 = T1
   T2 = T2
   End If
   End If
   End If
   If T0 <> "" Then
   If (T2 <> "") Then
   If (T1 = "") Then
   T0 = T0
   T2 = " æ" & T2
   T1 = T1
   End If
   End If
   End If
   If T0 = "" Then
   If (T2 <> "") Then
   If (T1 = "") Then
   T0 = T0
   T1 = T1
   T2 = T2
   End If
   End If
   End If
   If T0 = "æÇÍÏ" Then
            T0 = ""
            Resultat = Resultat & T0 & " ãáíæä"
       End If
       If T0 = "ÇËäÇä" Then
          T0 = ""
        Resultat = Resultat & T0 & " ãáíæäÇä"
       End If
       If Millions >= 3 And Millions <= 10 Then
      Resultat = Resultat & T0 & " ãáÇííä"
       End If
      If Millions >= 11 And Millions <= 999 Then
       Resultat = Resultat & T0 & " ãáíæä"
    Else
        Resultat = Resultat & ""
    End If
        If T1 = "æÇÍÏ" Then
            T1 = ""
            Resultat = Resultat & T1 & " ÃáÝ"
        End If
        If T1 = "ÇËäÇä" Then
            T1 = ""
            Resultat = Resultat & T1 & " ÃáÝÇä"
        End If
        If Milliers >= 3 And Milliers <= 10 Then
        Resultat = Resultat & T1 & " ÂáÇÝ"
        End If
        If Milliers >= 11 And Milliers <= 999 Then
        Resultat = Resultat & T1 & " ÃáÝ"
    Else
        Resultat = Resultat & ""
    End If
    If T2 <> "" Then
        Resultat = Resultat & T2 & " ÏíäÇÑ ßæíÊí"
    Else
        إذا كانت النتيجة <> "" ثم
            النتيجة = النتيجة & "سينار كويتي"
        إنهاء إذا
    إنهاء إذا
    إذا كان T3 <> "" ثم
        إذا كانت النتيجة <> "" ثم
            Resultat = Resultat & "æ" & T3 & "علاء"
        آخر
            Resultat = T3 & "صلاح"
        إنهاء إذا
    إنهاء إذا
    رقم ArabicT = النتيجة
وظيفة النهاية

 

يمكنك أيضا مشاهده

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

المرجع الشامل لدوال الاكسيل تحميل مباشر من هنا

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

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

شاهدنا في هذا المقال كود التفقيط باللغة العربية Excel يصلح لجميع العملات و يقبل الارقام العشريه حتي ثلاث ارقام عشريه و أيضا كود باللغه الانجليزيه الكود جاهز و سبق نشره علي موقع مايكروسوفت صفحه الدعم العربي للاوفيس