تعديل على الكود ( فقرة الفلس) ليصبح يقرأ (3) ارقام

[نبا زيد]

السلام عليكم

محتاج تعديل على الكود ليقوم بقرأءة (3) ارقام

حاليا الكود يقرأ رقمين

وكما مبين بالملف المرفق

او معادلة 

تعديل المبلغ - فلس.xlsm

تم تعديل الأربعاء at 07:58 بواسطه نبا زيد

[نبا زيد]

حاليا الكود يقرأ (الفلس) رقمين ، فمثلاً (369,258,126.223 ) اثنان وعشرون فلس 

المطلوب يقرأ 3 ارقام ( اثنان وثلاثة وعشرون فلس )

جزيتم خير

[محمد هشام.]

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

 

Function NumtoTxt(TheNo As Double, MyCur As String, MySubCur As String) As String
    Dim txtArr1(0 To 9) As String, txtArr2(0 To 9) As String, txtArr3(0 To 9) As String
    Dim Myno As String, GetNo As String, RdNo As String, My100 As String, I As Integer
    Dim My10 As String, My1 As String, My11 As String, My12 As String, GetTxt As String
    Dim MyAnd As String, Mybillion As String, MyMillion As String, MyThou As String
    Dim MyHun As String, MyFraction As String, ReMark As String

    If TheNo > 999999999999.999 Then Exit Function
    If TheNo < 0 Then TheNo = TheNo * -1: ReMark = "يتبقى لكم " Else ReMark = ""
    If TheNo = 0 Then NumtoTxt = "صفر": Exit Function

    MyAnd = " و"
    txtArr1(0) = "": txtArr1(1) = "مائة": txtArr1(2) = "مائتان": txtArr1(3) = "ثلاثمائة": txtArr1(4) = "أربعمائة"
    txtArr1(5) = "خمسمائة": txtArr1(6) = "ستمائة": txtArr1(7) = "سبعمائة": txtArr1(8) = "ثمانمائة": txtArr1(9) = "تسعمائة"

    txtArr2(0) = "": txtArr2(1) = "عشر": txtArr2(2) = "عشرون": txtArr2(3) = "ثلاثون": txtArr2(4) = "أربعون"
    txtArr2(5) = "خمسون": txtArr2(6) = "ستون": txtArr2(7) = "سبعون": txtArr2(8) = "ثمانون": txtArr2(9) = "تسعون"

    txtArr3(0) = "": txtArr3(1) = "واحد": txtArr3(2) = "اثنان": txtArr3(3) = "ثلاثة": txtArr3(4) = "أربعة"
    txtArr3(5) = "خمسة": txtArr3(6) = "ستة": txtArr3(7) = "سبعة": txtArr3(8) = "ثمانية": txtArr3(9) = "تسعة"

    GetNo = Format(TheNo, "000000000000.000")
    I = 0
    Do While I < 15

    If I < 12 Then
            Myno = Mid$(GetNo, I + 1, 3)
        ElseIf I = 12 Then
            Myno = Mid$(GetNo, I + 2, 3)
        End If


        If Val(Myno) > 0 Then
            RdNo = Mid$(Myno, 1, 1): My100 = txtArr1(Val(RdNo))
            RdNo = Mid$(Myno, 3, 1): My1 = txtArr3(Val(RdNo))
            RdNo = Mid$(Myno, 2, 1): My10 = txtArr2(Val(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 Val(Mid$(Myno, 1, 1)) > 0 And Val(Mid$(Myno, 2, 2)) > 0 Then My100 = My100 + MyAnd
            If Val(Mid$(Myno, 3, 1)) > 0 And Val(Mid$(Myno, 2, 1)) > 1 Then My1 = My1 + MyAnd

            GetTxt = My100 + My1 + My10

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

            If I = 0 And GetTxt <> "" Then
                If Val(Myno) > 10 Then Mybillion = GetTxt + " مليار" Else Mybillion = GetTxt + " مليارات"
                If Val(Myno) = 1 Then Mybillion = "مليار"
                If Val(Myno) = 2 Then Mybillion = "ملياران"
            End If

            If I = 3 And GetTxt <> "" Then
                If Val(Myno) > 10 Then MyMillion = GetTxt + " مليون" Else MyMillion = GetTxt + " ملايين"
                If Val(Myno) = 1 Then MyMillion = "مليون"
                If Val(Myno) = 2 Then MyMillion = "مليونان"
            End If

            If I = 6 And GetTxt <> "" Then
                If Val(Myno) > 10 Then MyThou = GetTxt + " ألف" Else MyThou = GetTxt + " آلاف"
                If Val(Mid$(Myno, 3, 1)) = 1 Then MyThou = "ألف"
                If Val(Mid$(Myno, 3, 1)) = 2 Then MyThou = "ألفان"
            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
    If MyMillion <> "" Then If MyThou <> "" Or MyHun <> "" Then MyMillion = MyMillion + MyAnd
    If MyThou <> "" Then If MyHun <> "" Then MyThou = MyThou + MyAnd

    If MyFraction <> "" Then
        If Mybillion <> "" Or MyMillion <> "" Or MyThou <> "" Or MyHun <> "" Then
            NumtoTxt = ReMark & Mybillion & MyMillion & MyThou & MyHun & " " & MyCur & MyAnd & MyFraction & " " & MySubCur
        Else
            NumtoTxt = ReMark & MyFraction & " " & MySubCur
        End If
    Else
        NumtoTxt = ReMark & Mybillion & MyMillion & MyThou & MyHun & " " & MyCur
    End If
End Function

 

تعديل المبلغ - فلس V2.xlsm

[نبا زيد]

جزاك الله عنا خيرا كثيرا جدا

ممنون

تمام 100 %

هو المطلوب