تحويل الأرقام الى حرووف

محمد اليازجي · مايو 6, 2013

اولا اشكر لكم متابعتكم

اريد الكيفية التي استطيع فيها تحويل الارقام الى حروف

مثلا 1500$ فقط ألف وخمسمائة دولار لاغير

وهكذا ويكون متضمن الكسور

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

**شوقي ربيع** · مايو 6, 2013

شاهد هذا الرابط

http://www.officena.net/ib/index.php?showtopic=45870

1.4k · مايو 6, 2013

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

مرفق داله جاهزه وجدتها فى خزينتى للتفقيط الى دولار

مرفق ملف

السلام عليكم

تفقيط دولار.rar

تم تعديل مايو 6, 2013 بواسطه هادى محمد المامون سالم

محمد اليازجي · مايو 6, 2013

اولا اشكر لكم متابعتكم

اريد الكيفية التي استطيع فيها تحويل الارقام الى حروف

مثلا 1500$    فقط ألف وخمسمائة دولار لاغير

وهكذا ويكون متضمن الكسور

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

1.

اضغطALT+F11 لبدءVisual Basic Editor.

3.

On the Insert menu, click Module.

4.

خذ هذا الكود وادخله داخل المودل.

Option Explicit

'Main Function

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

في الخلية التي تريد فيها تحويل الارقام الى احرف

اكتب المعادلة التالية

=SpellNumber(A1) مثلا في الخلية a1

وستظهر لكل الارقم قد تحولت الى احرف

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

محمد اليازجي · مايو 6, 2013

اولا اشكر لكم متابعتكم

اريد الكيفية التي استطيع فيها تحويل الارقام الى حروف

مثلا 1500$    فقط ألف وخمسمائة دولار لاغير

وهكذا ويكون متضمن الكسور

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

1.

اضغطALT+F11 لبدءVisual Basic Editor.

3.

On the Insert menu, click Module.

4.

خذ هذا الكود وادخله داخل المودل.

Option Explicit

'Main Function

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

في الخلية التي تريد فيها تحويل الارقام الى احرف

اكتب المعادلة التالية

=SpellNumber(A1) مثلا في الخلية a1

وستظهر لكل الارقم قد تحولت الى احرف

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

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

**حمادة عمر** · مايو 6, 2013

الاخ الكريم / محمد اليازجي

جاء الرد علي طلبك الاخير بخصوص التفقيط بالعربي في الرابط المرسل من الاخ الحبيب / شوقي ربيع .. جزاه الله خيرا ... وهو يفي بالمطلوب

واليك كود آخر ... قم بوضع الكود التالي في مودل

Function NoToTxt(TheNo As Double, MyCur As String, MySubCur As String) As String
Dim MyArry1(0 To 9) As String
Dim MyArry2(0 To 9) As String
Dim MyArry3(0 To 9) As String
Dim Myno As String
Dim GetNo As String
Dim RdNo As String
Dim My100 As String
Dim My10 As String
Dim My1 As String
Dim My11 As String
Dim My12 As String
Dim GetTxt As String
Dim Mybillion As String
Dim MyMillion As String
Dim MyThou As String
Dim MyHun As String
Dim MyFraction As String
Dim MyAnd As String
Dim i As Integer
Dim ReMark As String


If TheNo > 999999999999.99 Then Exit Function

If TheNo < 0 Then
TheNo = TheNo * -1
ReMark = "íÊÈÞì áßã "
Else
ReMark = "ÝÞØ "
End If

If TheNo = 0 Then
NoToTxt = "ÕÝÑ"
Exit Function
End If

MyAnd = " æ"
MyArry1(0) = ""
MyArry1(1) = "ãÇÆÉ"
MyArry1(2) = "ãÇÆÊÇä"
MyArry1(3) = "ËáÇËãÇÆÉ"
MyArry1(4) = "ÃÑÈÚãÇÆÉ"
MyArry1(5) = "ÎãÓãÇÆÉ"
MyArry1(6) = "ÓÊãÇÆÉ"
MyArry1(7) = "ÓÈÚãÇÆÉ"
MyArry1(8) = "ËãÇäãÇÆÉ"
MyArry1(9) = "ÊÓÚãÇÆÉ"

MyArry2(0) = ""
MyArry2(1) = " ÚÔÑ"
MyArry2(2) = "ÚÔÑæä"
MyArry2(3) = "ËáÇËæä"
MyArry2(4) = "ÃÑÈÚæä"
MyArry2(5) = "ÎãÓæä"
MyArry2(6) = "ÓÊæä"
MyArry2(7) = "ÓÈÚæä"
MyArry2(8) = "ËãÇäæä"
MyArry2(9) = "ÊÓÚæä"

MyArry3(0) = ""
MyArry3(1) = "æÇÍÏ"
MyArry3(2) = "ÇËäÇä"
MyArry3(3) = "ËáÇËÉ"
MyArry3(4) = "ÃÑÈÚÉ"
MyArry3(5) = "ÎãÓÉ"
MyArry3(6) = "ÓÊÉ"
MyArry3(7) = "ÓÈÚÉ"
MyArry3(8) = "ËãÇäíÉ"
MyArry3(9) = "ÊÓÚÉ"
'======================

GetNo = Format(TheNo, "000000000000.00")

i = 0
Do While i < 15

If i < 12 Then
Myno = Mid$(GetNo, i + 1, 3)
Else
Myno = "0" + Mid$(GetNo, i + 2, 2)
End If

If (Mid$(Myno, 1, 3)) > 0 Then

RdNo = Mid$(Myno, 1, 1)
My100 = MyArry1(RdNo)
RdNo = Mid$(Myno, 3, 1)
My1 = MyArry3(RdNo)
RdNo = Mid$(Myno, 2, 1)
My10 = MyArry2(RdNo)

If Mid$(Myno, 2, 2) = 11 Then My11 = "ÅÍÏì ÚÔÑ"
If Mid$(Myno, 2, 2) = 12 Then My12 = "ÅËäì ÚÔÑ"
If Mid$(Myno, 2, 2) = 10 Then My10 = "ÚÔÑÉ"

If ((Mid$(Myno, 1, 1)) > 0) And ((Mid$(Myno, 2, 2)) > 0) Then My100 = My100 + MyAnd
If ((Mid$(Myno, 3, 1)) > 0) And ((Mid$(Myno, 2, 1)) > 1) Then My1 = My1 + MyAnd

GetTxt = My100 + My1 + My10

If ((Mid$(Myno, 3, 1)) = 1) And ((Mid$(Myno, 2, 1)) = 1) Then
GetTxt = My100 + My11
If ((Mid$(Myno, 1, 1)) = 0) Then GetTxt = My11
End If

If ((Mid$(Myno, 3, 1)) = 2) And ((Mid$(Myno, 2, 1)) = 1) Then
GetTxt = My100 + My12
If ((Mid$(Myno, 1, 1)) = 0) Then GetTxt = My12
End If

If (i = 0) And (GetTxt <> "") Then
If ((Mid$(Myno, 1, 3)) > 10) Then
Mybillion = GetTxt + " ãáíÇÑ"
Else
Mybillion = GetTxt + " ãáíÇÑÇÊ"
If ((Mid$(Myno, 1, 3)) = 2) Then Mybillion = " ãáíÇÑ"
If ((Mid$(Myno, 1, 3)) = 2) Then Mybillion = " ãáíÇÑÇä"
End If
End If

If (i = 3) And (GetTxt <> "") Then

If ((Mid$(Myno, 1, 3)) > 10) Then
MyMillion = GetTxt + " ãáíæä"
Else
MyMillion = GetTxt + " ãáÇííä"
If ((Mid$(Myno, 1, 3)) = 1) Then MyMillion = " ãáíæä"
If ((Mid$(Myno, 1, 3)) = 2) Then MyMillion = " ãáíæäÇä"
End If
End If

If (i = 6) And (GetTxt <> "") Then
If ((Mid$(Myno, 1, 3)) > 10) Then
MyThou = GetTxt + " ÃáÝ"
Else
MyThou = GetTxt + " ÂáÇÝ"
If ((Mid$(Myno, 3, 1)) = 1) Then MyThou = " ÃáÝ"
If ((Mid$(Myno, 3, 1)) = 2) Then MyThou = " ÃáÝÇä"
End If
End If

If (i = 9) And (GetTxt <> "") Then MyHun = GetTxt
If (i = 12) And (GetTxt <> "") Then MyFraction = GetTxt
End If

i = i + 3
Loop

If (Mybillion <> "") Then
If (MyMillion <> "") Or (MyThou <> "") Or (MyHun <> "") Then Mybillion = Mybillion + MyAnd
End If

If (MyMillion <> "") Then
If (MyThou <> "") Or (MyHun <> "") Then MyMillion = MyMillion + MyAnd
End If

If (MyThou <> "") Then
If (MyHun <> "") Then MyThou = MyThou + MyAnd
End If

If MyFraction <> "" Then
If (Mybillion <> "") Or (MyMillion <> "") Or (MyThou <> "") Or (MyHun <> "") Then
NoToTxt = ReMark + Mybillion + MyMillion + MyThou + MyHun + " " + MyCur + MyAnd + MyFraction + " " + MySubCur
Else
NoToTxt = ReMark + MyFraction + " " + MySubCur
End If
Else
NoToTxt = ReMark + Mybillion + MyMillion + MyThou + MyHun + " " + MyCur
End If

End Function

ثم ضع المعادلة التاليه في الخليه التي تريد فيها التفقيط

=NOTOTXT(A1;"جنيهاً";"قرشاً")

جزاك الله خيرا

تسجيل الدخول

تحويل الأرقام الى حرووف

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

محمد اليازجي

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

شارك

شوقي ربيع

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

شارك

هادى محمد المامون سالم

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

شارك

محمد اليازجي

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

شارك

محمد اليازجي

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

شارك

حمادة عمر

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

شارك

Join the conversation

تصفح هذا الموضوع مؤخراً 0 اعضاء متواجدين الان

تصفح الموقع

تصفح جديد الموقع

Support

Important Information