تبدیل عدد به حروف در اکسل | آموزش ساده و کاربردی

' VBA Function to Convert Number to Word in Excel
Function NumToWords(ByVal MyNumber As Variant, Optional isProper As Boolean = False) As String
    Dim Units As String, SubUnits As String, TempStr As String
    Dim DecimalPlace As Integer, Count As Integer
    Dim Place(9) As String
    Dim strNumber As String
    
    ' Define Place values
    Place(2) = " Thousand "
    Place(3) = " Million "
    Place(4) = " Billion "
    Place(5) = " Trillion "
    Place(6) = " Quadrillion "
    Place(7) = " Quintillion "
    
    ' Check if the input is empty or not a number
    If IsEmpty(MyNumber) Or Not IsNumeric(MyNumber) Then
        NumToWords = ""
        Exit Function
    End If

    ' FIX 1: Convert to string using Format to avoid Scientific Notation (e.g., 1E+10)
    ' This ensures we get pure digits.
    strNumber = Trim(Format(MyNumber, "0.################"))

    ' Handle Zero Case (Pure Zero)
    If Val(strNumber) = 0 And InStr(strNumber, ".") = 0 And InStr(strNumber, ",") = 0 Then
        NumToWords = "Zero"
        Exit Function
    End If

    ' FIX 2: Handle Decimal Separator (Dot or Comma)
    ' We normalize commas to dots to make the rest of the logic standard
    strNumber = Replace(strNumber, ",", ".")
    
    ' Find position of decimal place
    DecimalPlace = InStr(strNumber, ".")

    ' Convert Decimal Part
    If DecimalPlace > 0 Then
        ' Extract the decimal part
        SubUnits = GetDecimalWords(Mid(strNumber, DecimalPlace + 1), isProper)
        ' Remove decimal part from the main string for integer processing
        strNumber = Trim(Left(strNumber, DecimalPlace - 1))
    End If

    ' Process Integer Part
    Count = 1
    Do While strNumber <> ""
        TempStr = GetHundreds(Right(strNumber, 3))
        
        ' Only add the Place name if the group isn't 000
        If TempStr <> "" Then
             ' Place(1) is empty by default, which correctly handles the "Hundreds" group
            Units = TempStr & Place(Count) & Units
        End If
        
        ' Slice off the last 3 digits
        If Len(strNumber) > 3 Then
            strNumber = Left(strNumber, Len(strNumber) - 3)
        Else
            strNumber = ""
        End If
        
        Count = Count + 1
        ' Safety break to prevent errors if number exceeds defined Places
        If Count > UBound(Place) Then Exit Do
    Loop

    ' Combine Integer and Decimal Parts
    If SubUnits = "" Then
        NumToWords = Application.Trim(Units)
    Else
        ' If Integer part was effectively zero (e.g., input was 0.50)
        If Units = "" Then Units = "Zero"
        NumToWords = Application.Trim(Units & " Point " & SubUnits)
    End If
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 Hundreds Place
    If Mid(MyNumber, 1, 1) <> "0" Then
        Result = GetDigit(Mid(MyNumber, 1, 1)) & " Hundred "
    End If
    
    ' Convert 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 = ""
    
    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"
        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 "
        End Select
        Result = Result & GetDigit(Right(TensText, 1))
    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

' Converts Decimal Digits to Words
Function GetDecimalWords(DecimalPart As String, isProper As Boolean) As String
    Dim i As Integer, DecWord As String
    Dim TwoDigits As String

    If isProper Then
        ' Mode: Digit by Digit (e.g., 87.04 -> "Eighty Seven Point Zero Four")
        For i = 1 To Len(DecimalPart)
            If i > 1 Then DecWord = DecWord & " "
            
            ' FIX: Explicitly handle "0" so it says "Zero" instead of skipping it
            If Mid(DecimalPart, i, 1) = "0" Then
                DecWord = DecWord & "Zero"
            Else
                DecWord = DecWord & GetDigit(Mid(DecimalPart, i, 1))
            End If
        Next i
    Else
        ' Mode: Pairs (Standard)
        ' Logic: Take first two digits. If it is "04", we must force "Zero Four".
        
        TwoDigits = Left(DecimalPart & "00", 2)
        
        ' FIX: Check if the pair starts with 0 (and isn't 00)
        If Left(TwoDigits, 1) = "0" And TwoDigits <> "00" Then
             DecWord = "Zero " & GetDigit(Right(TwoDigits, 1))
        Else
             DecWord = GetTens(TwoDigits)
        End If
    End If

    GetDecimalWords = DecWord
End Function

Option Explicit

' ==========================================
' Main Function
' Usage:
' =NumberToWordsFa
' ==========================================

Function NumberToWordsFa(ByVal MyNumber As Variant) As String

    Dim NumberText As String
    Dim WholePart As String
    Dim DecimalPart As String
    Dim DecimalPlace As Long
    Dim Result As String
    Dim IsNegative As Boolean
    Dim i As Long

    NumberText = Trim(CStr(MyNumber))

    ' Remove commas
    NumberText = Replace(NumberText, ",", "")

    ' Check negative number
    If Left(NumberText, 1) = "-" Then
        IsNegative = True
        NumberText = Mid(NumberText, 2)
    End If

    ' Check decimal point
    DecimalPlace = InStr(NumberText, ".")

    If DecimalPlace > 0 Then
        WholePart = Left(NumberText, DecimalPlace - 1)
        DecimalPart = Mid(NumberText, DecimalPlace + 1)
    Else
        WholePart = NumberText
        DecimalPart = ""
    End If

    ' Remove leading zeros
    Do While Len(WholePart) > 1 And Left(WholePart, 1) = "0"
        WholePart = Mid(WholePart, 2)
    Loop

    ' Convert whole number
    Result = ConvertLargeNumber(WholePart)

    ' Zero
    If Result = "" Then
        Result = F_Zero()
    End If

    ' Negative
    If IsNegative Then
        Result = F_Negative() & " " & Result
    End If

    ' Decimal part
    If DecimalPart <> "" Then

        Result = Result & " " & F_And() & " " & F_Decimal()

        For i = 1 To Len(DecimalPart)
            Result = Result & " " & GetDigitFa(Mid(DecimalPart, i, 1))
        Next i

    End If

    NumberToWordsFa = Application.WorksheetFunction.Trim(Result)

End Function


' ==========================================
' Convert large numbers
' ==========================================

Private Function ConvertLargeNumber(ByVal NumberText As String) As String

    Dim Groups() As String
    Dim GroupCount As Long
    Dim i As Long
    Dim GroupText As String
    Dim Result As String
    Dim ScaleText As String

    GroupCount = 0

    ' Split number into 3-digit groups
    Do While Len(NumberText) > 0

        GroupCount = GroupCount + 1
        ReDim Preserve Groups(1 To GroupCount)

        If Len(NumberText) > 3 Then

            Groups(GroupCount) = Right(NumberText, 3)
            NumberText = Left(NumberText, Len(NumberText) - 3)

        Else

            Groups(GroupCount) = NumberText
            NumberText = ""

        End If

    Loop

    ' Process groups from left to right
    For i = GroupCount To 1 Step -1

        GroupText = ThreeDigitFa(Groups(i))

        If GroupText <> "" Then

            ScaleText = GetScaleFa(i)

            If Result <> "" Then
                Result = Result & " " & F_And() & " "
            End If

            Result = Result & GroupText

            If ScaleText <> "" Then
                Result = Result & " " & ScaleText
            End If

        End If

    Next i

    ConvertLargeNumber = Result

End Function


' ==========================================
' Convert 0 - 999
' ==========================================

Private Function ThreeDigitFa(ByVal NumberText As String) As String

    Dim N As Long
    Dim Hundreds As Long
    Dim Tens As Long
    Dim Ones As Long
    Dim Result As String

    N = Val(NumberText)

    If N = 0 Then
        ThreeDigitFa = ""
        Exit Function
    End If

    Hundreds = N \ 100
    Tens = (N Mod 100) \ 10
    Ones = N Mod 10

    ' Hundreds
    If Hundreds > 0 Then
        Result = GetHundredFa(Hundreds)
    End If

    ' ۱ - ۱۹
    If (N Mod 100) >= 1 And (N Mod 100) <= 19 Then

        If Result <> "" Then
            Result = Result & " " & F_And() & " "
        End If

        Result = Result & GetTeenFa(N Mod 100)

    Else

        ' Tens
        If Tens > 0 Then

            If Result <> "" Then
                Result = Result & " " & F_And() & " "
            End If

            Result = Result & GetTensFa(Tens)

        End If

        ' Ones
        If Ones > 0 Then

            If Result <> "" Then
                Result = Result & " " & F_And() & " "
            End If

            Result = Result & GetDigitFa(CStr(Ones))

        End If

    End If

    ThreeDigitFa = Result

End Function


' ==========================================
' Hundreds
' ==========================================

Private Function GetHundredFa(ByVal N As Long) As String

    Select Case N

        Case 1
            GetHundredFa = F_OneHundred()

        Case 2
            GetHundredFa = F_TwoHundred()

        Case 3
            GetHundredFa = F_ThreeHundred()

        Case 4
            GetHundredFa = F_FourHundred()

        Case 5
            GetHundredFa = F_FiveHundred()

        Case 6
            GetHundredFa = F_SixHundred()

        Case 7
            GetHundredFa = F_SevenHundred()

        Case 8
            GetHundredFa = F_EightHundred()

        Case 9
            GetHundredFa = F_NineHundred()

    End Select

End Function


' ==========================================
' Numbers 1 - 19
' ==========================================

Private Function GetTeenFa(ByVal N As Long) As String

    Select Case N

        Case 1
            GetTeenFa = F_One()

        Case 2
            GetTeenFa = F_Two()

        Case 3
            GetTeenFa = F_Three()

        Case 4
            GetTeenFa = F_Four()

        Case 5
            GetTeenFa = F_Five()

        Case 6
            GetTeenFa = F_Six()

        Case 7
            GetTeenFa = F_Seven()

        Case 8
            GetTeenFa = F_Eight()

        Case 9
            GetTeenFa = F_Nine()

        Case 10
            GetTeenFa = F_Ten()

        Case 11
            GetTeenFa = F_Eleven()

        Case 12
            GetTeenFa = F_Twelve()

        Case 13
            GetTeenFa = F_Thirteen()

        Case 14
            GetTeenFa = F_Fourteen()

        Case 15
            GetTeenFa = F_Fifteen()

        Case 16
            GetTeenFa = F_Sixteen()

        Case 17
            GetTeenFa = F_Seventeen()

        Case 18
            GetTeenFa = F_Eighteen()

        Case 19
            GetTeenFa = F_Nineteen()

    End Select

End Function


' ==========================================
' Tens
' ==========================================

Private Function GetTensFa(ByVal N As Long) As String

    Select Case N

        Case 2
            GetTensFa = F_Twenty()

        Case 3
            GetTensFa = F_Thirty()

        Case 4
            GetTensFa = F_Forty()

        Case 5
            GetTensFa = F_Fifty()

        Case 6
            GetTensFa = F_Sixty()

        Case 7
            GetTensFa = F_Seventy()

        Case 8
            GetTensFa = F_Eighty()

        Case 9
            GetTensFa = F_Ninety()

    End Select

End Function


' ==========================================
' Single digit
' ==========================================

Private Function GetDigitFa(ByVal Digit As String) As String

    Select Case Val(Digit)

        Case 0
            GetDigitFa = F_Zero()

        Case 1
            GetDigitFa = F_One()

        Case 2
            GetDigitFa = F_Two()

        Case 3
            GetDigitFa = F_Three()

        Case 4
            GetDigitFa = F_Four()

        Case 5
            GetDigitFa = F_Five()

        Case 6
            GetDigitFa = F_Six()

        Case 7
            GetDigitFa = F_Seven()

        Case 8
            GetDigitFa = F_Eight()

        Case 9
            GetDigitFa = F_Nine()

    End Select

End Function


' ==========================================
' Scale names
' ==========================================

Private Function GetScaleFa(ByVal GroupNumber As Long) As String

    Select Case GroupNumber

        Case 1
            GetScaleFa = ""

        Case 2
            GetScaleFa = F_Thousand()

        Case 3
            GetScaleFa = F_Million()

        Case 4
            GetScaleFa = F_Billion()

        Case 5
            GetScaleFa = F_Trillion()

        Case 6
            GetScaleFa = F_Quadrillion()

        Case 7
            GetScaleFa = F_Quintillion()

        Case 8
            GetScaleFa = F_Sextillion()

        Case 9
            GetScaleFa = F_Septillion()

        Case 10
            GetScaleFa = F_Octillion()

        Case Else
            GetScaleFa = ""

    End Select

End Function


' ==========================================
' Persian words using ChrW()
' No Persian characters are used in source code
' ==========================================

Private Function F_Zero()
    F_Zero = ChrW(1589) & ChrW(1601) & ChrW(1585)
End Function

Private Function F_One()
    F_One = ChrW(1740) & ChrW(1705)
End Function

Private Function F_Two()
    F_Two = ChrW(1583) & ChrW(1608)
End Function

Private Function F_Three()
    F_Three = ChrW(1587) & ChrW(1607)
End Function

Private Function F_Four()
    F_Four = ChrW(1670) & ChrW(1607) & ChrW(1575) & ChrW(1585)
End Function

Private Function F_Five()
    F_Five = ChrW(1662) & ChrW(1606) & ChrW(1580)
End Function

Private Function F_Six()
    F_Six = ChrW(1588) & ChrW(1588)
End Function

Private Function F_Seven()
    F_Seven = ChrW(1607) & ChrW(1601) & ChrW(1578)
End Function

Private Function F_Eight()
    F_Eight = ChrW(1607) & ChrW(1588) & ChrW(1578)
End Function

Private Function F_Nine()
    F_Nine = ChrW(1606) & ChrW(1607)
End Function

Private Function F_Ten()
    F_Ten = ChrW(1583) & ChrW(1607)
End Function

Private Function F_Eleven()
    F_Eleven = ChrW(1740) & ChrW(1575) & ChrW(1586) & ChrW(1583) & ChrW(1607)
End Function

Private Function F_Twelve()
    F_Twelve = ChrW(1583) & ChrW(1608) & ChrW(1575) & ChrW(1586) & ChrW(1583) & ChrW(1607)
End Function

Private Function F_Thirteen()
    F_Thirteen = ChrW(1587) & ChrW(1740) & ChrW(1586) & ChrW(1583) & ChrW(1607)
End Function

Private Function F_Fourteen()
    F_Fourteen = ChrW(1670) & ChrW(1607) & ChrW(1575) & ChrW(1585) & ChrW(1583) & ChrW(1607)
End Function

Private Function F_Fifteen()
    F_Fifteen = ChrW(1662) & ChrW(1575) & ChrW(1606) & ChrW(1586) & ChrW(1583) & ChrW(1607)
End Function

Private Function F_Sixteen()
    F_Sixteen = ChrW(1588) & ChrW(1575) & ChrW(1606) & ChrW(1586) & ChrW(1583) & ChrW(1607)
End Function

Private Function F_Seventeen()
    F_Seventeen = ChrW(1607) & ChrW(1601) & ChrW(1583) & ChrW(1607)
End Function

Private Function F_Eighteen()
    F_Eighteen = ChrW(1607) & ChrW(1580) & ChrW(1583) & ChrW(1607)
End Function

Private Function F_Nineteen()
    F_Nineteen = ChrW(1606) & ChrW(1608) & ChrW(1586) & ChrW(1583) & ChrW(1607)
End Function


' ==========================================
' Tens
' ==========================================

Private Function F_Twenty()
    F_Twenty = ChrW(1576) & ChrW(1740) & ChrW(1587) & ChrW(1578)
End Function

Private Function F_Thirty()
    F_Thirty = ChrW(1587) & ChrW(1740)
End Function

Private Function F_Forty()
    F_Forty = ChrW(1670) & ChrW(1607) & ChrW(1604)
End Function

Private Function F_Fifty()
    F_Fifty = ChrW(1662) & ChrW(1606) & ChrW(1580) & ChrW(1575) & ChrW(1607)
End Function

Private Function F_Sixty()
    F_Sixty = ChrW(1588) & ChrW(1589) & ChrW(1578)
End Function

Private Function F_Seventy()
    F_Seventy = ChrW(1607) & ChrW(1601) & ChrW(1578) & ChrW(1575) & ChrW(1583)
End Function

Private Function F_Eighty()
    F_Eighty = ChrW(1607) & ChrW(1588) & ChrW(1578) & ChrW(1575) & ChrW(1583)
End Function

Private Function F_Ninety()
    F_Ninety = ChrW(1606) & ChrW(1608) & ChrW(1583)
End Function


' ==========================================
' Hundreds
' ==========================================

Private Function F_OneHundred()
    F_OneHundred = ChrW(1589) & ChrW(1583)
End Function

Private Function F_TwoHundred()
    F_TwoHundred = ChrW(1583) & ChrW(1608) & ChrW(1740) & ChrW(1587) & ChrW(1578)
End Function

Private Function F_ThreeHundred()
    F_ThreeHundred = ChrW(1587) & ChrW(1740) & ChrW(1589) & ChrW(1583)
End Function

Private Function F_FourHundred()
    F_FourHundred = ChrW(1670) & ChrW(1607) & ChrW(1575) & ChrW(1585) & " " & ChrW(1589) & ChrW(1583)
End Function

Private Function F_FiveHundred()
    F_FiveHundred = ChrW(1662) & ChrW(1575) & ChrW(1606) & ChrW(1589) & ChrW(1583)
End Function

Private Function F_SixHundred()
    F_SixHundred = ChrW(1588) & ChrW(1588) & ChrW(1589) & ChrW(1583)
End Function

Private Function F_SevenHundred()
    F_SevenHundred = ChrW(1607) & ChrW(1601) & ChrW(1578) & ChrW(1589) & ChrW(1583)
End Function

Private Function F_EightHundred()
    F_EightHundred = ChrW(1607) & ChrW(1588) & ChrW(1578) & ChrW(1589) & ChrW(1583)
End Function

Private Function F_NineHundred()
    F_NineHundred = ChrW(1606) & ChrW(1607) & ChrW(1589) & ChrW(1583)
End Function


' ==========================================
' Common words
' ==========================================

Private Function F_And()
    F_And = ChrW(1608)
End Function

Private Function F_Thousand()
    F_Thousand = ChrW(1607) & ChrW(1586) & ChrW(1575) & ChrW(1585)
End Function

Private Function F_Million()
    F_Million = ChrW(1605) & ChrW(1740) & ChrW(1604) & ChrW(1740) & ChrW(1608) & ChrW(1606)
End Function

Private Function F_Billion()
    F_Billion = ChrW(1605) & ChrW(1740) & ChrW(1604) & ChrW(1740) & ChrW(1575) & ChrW(1585) & ChrW(1583)
End Function

Private Function F_Trillion()
    F_Trillion = ChrW(1578) & ChrW(1585) & ChrW(1740) & ChrW(1604) & ChrW(1740) & ChrW(1608) & ChrW(1606)
End Function

Private Function F_Quadrillion()
    F_Quadrillion = ChrW(1705) & ChrW(1575) & ChrW(1583) & ChrW(1585) & ChrW(1740) & ChrW(1604) & ChrW(1740) & ChrW(1608) & ChrW(1606)
End Function

Private Function F_Quintillion()
    F_Quintillion = ChrW(1705) & ChrW(1608) & ChrW(1575) & ChrW(1606) & ChrW(1578) & ChrW(1740) & ChrW(1604) & ChrW(1740) & ChrW(1608) & ChrW(1606)
End Function

Private Function F_Sextillion()
    F_Sextillion = ChrW(1587) & ChrW(1705) & ChrW(1587) & ChrW(1578) & ChrW(1740) & ChrW(1604) & ChrW(1740) & ChrW(1608) & ChrW(1606)
End Function

Private Function F_Septillion()
    F_Septillion = ChrW(1587) & ChrW(1662) & ChrW(1578) & ChrW(1740) & ChrW(1604) & ChrW(1740) & ChrW(1608) & ChrW(1606)
End Function

Private Function F_Octillion()
    F_Octillion = ChrW(1575) & ChrW(1705) & ChrW(1578) & ChrW(1575) & ChrW(1604) & ChrW(1740) & ChrW(1608) & ChrW(1606)
End Function

Private Function F_Negative()
    F_Negative = ChrW(1605) & ChrW(1606) & ChrW(1601) & ChrW(1740)
End Function

Private Function F_Decimal()
    F_Decimal = ChrW(1575) & ChrW(1593) & ChrW(1588) & ChrW(1575) & ChrW(1585) & ChrW(1740)
End Function

=NUMWORD 

' Function to Convert Number to Words with Currency & Units
Function AmountToWords(ByVal MyNumber, ByVal strCurrency As String, ByVal strUnits As String) As String
    Dim IntegerPart As String, DecimalPart As String
    Dim DecimalPlace As Integer

    ' Check if the input is empty or not a number
    If IsEmpty(MyNumber) Or Not IsNumeric(MyNumber) Then
        AmountToWords = ""
        Exit Function
    End If
    
    ' Convert MyNumber to string and trim white space
    MyNumber = Trim(Str(MyNumber))
    
    ' Find position of decimal place (0 if none)
    DecimalPlace = InStr(MyNumber, ".")
    
    ' Get Integer and Decimal Parts
    If DecimalPlace > 0 Then
        IntegerPart = Trim(Left(MyNumber, DecimalPlace - 1))
        DecimalPart = Right(MyNumber, Len(MyNumber) - DecimalPlace)
    Else
        IntegerPart = MyNumber
        DecimalPart = ""
    End If
    
    ' Convert to words
    If IntegerPart <> "" Then
        AmountToWords = NumToWords(IntegerPart) & " " & strCurrency
    End If
    
    If DecimalPart <> "" And Val(DecimalPart) > 0 Then
        If AmountToWords <> "" Then AmountToWords = AmountToWords & " and "
        AmountToWords = AmountToWords & NumToWords(Left(DecimalPart & "00", 2)) & " " & strUnits
    End If
End Function

'****Make sure to have all the functions defined in the NumToWords function in the above section****

=AmountToWords(A1,"Dollars","Cents")

vb
Option Explicit

' ============================================================
' Persian Amount To Words
'
' Example:
' =AmountToWords(A1)
' =AmountToWords(A1, PersianRial(), PersianDinar())
'
' No Persian characters are stored directly in this VBA code.
' Persian text is generated using Unicode character codes.
' ============================================================


' ------------------------------------------------------------
' Main Function
' ------------------------------------------------------------
Public Function AmountToWords( _
    ByVal MyNumber As Variant, _
    Optional ByVal CurrencyName As String = "", _
    Optional ByVal DecimalName As String = "" _
) As String

    Dim NumberText As String
    Dim IntegerPart As String
    Dim DecimalPart As String
    Dim DecimalPos As Long
    Dim Result As String
    Dim IsNegative As Boolean

    ' Validate input
    If IsEmpty(MyNumber) Then
        AmountToWords = ""
        Exit Function
    End If

    If Not IsNumeric(MyNumber) Then
        AmountToWords = ""
        Exit Function
    End If

    ' Check negative number
    IsNegative = (CDbl(MyNumber) < 0)

    ' Convert number to text
    NumberText = Trim$(CStr(Abs(CDbl(MyNumber))))

    ' Normalize decimal separator
    NumberText = Replace(NumberText, ",", ".")

    ' Find decimal separator
    DecimalPos = InStr(1, NumberText, ".", vbBinaryCompare)

    If DecimalPos > 0 Then

        IntegerPart = Left$(NumberText, DecimalPos - 1)
        DecimalPart = Mid$(NumberText, DecimalPos + 1)

    Else

        IntegerPart = NumberText
        DecimalPart = ""

    End If

    ' Remove leading zeros
    IntegerPart = RemoveLeadingZeros(IntegerPart)

    If IntegerPart = "" Then
        IntegerPart = "0"
    End If

    ' Convert integer part
    Result = PersianNumberToWords(IntegerPart)

    ' Add negative sign
    If IsNegative Then
        Result = PersianNegativeWord() & " " & Result
    End If

    ' Add currency
    If CurrencyName <> "" Then
        Result = Result & " " & CurrencyName
    End If

    ' Convert decimal part
    If DecimalPart <> "" Then

        ' Keep two decimal digits
        DecimalPart = Left$(DecimalPart & "00", 2)

        ' Remove leading zeros only for evaluation
        If Val(DecimalPart) > 0 Then

            If Result <> "" Then
                Result = Result & " " & PersianAnd()
            End If

            Result = Result & _
                     PersianNumberToWords(CStr(Val(DecimalPart)))

            If DecimalName <> "" Then
                Result = Result & " " & DecimalName
            End If

        End If

    End If

    AmountToWords = Result

End Function


' ------------------------------------------------------------
' Convert full number to Persian words
' Supports up to 999,999,999,999,999
' ------------------------------------------------------------
Private Function PersianNumberToWords( _
    ByVal NumberText As String _
) As String

    Dim Groups(0 To 4) As String
    Dim Scales(0 To 4) As String

    Dim GroupIndex As Long
    Dim I As Long
    Dim GroupValue As Long
    Dim Result As String
    Dim GroupWords As String

    ' Persian scale names
    Scales(0) = ""
    Scales(1) = PersianThousand()
    Scales(2) = PersianMillion()
    Scales(3) = PersianBillion()
    Scales(4) = PersianTrillion()

    ' Handle zero
    If Val(NumberText) = 0 Then
        PersianNumberToWords = PersianZero()
        Exit Function
    End If

    ' Split number into groups of three digits
    GroupIndex = 0

    Do While Len(NumberText) > 0 And GroupIndex <= 4

        If Len(NumberText) > 3 Then

            Groups(GroupIndex) = _
                Right$(NumberText, 3)

            NumberText = _
                Left$(NumberText, Len(NumberText) - 3)

        Else

            Groups(GroupIndex) = NumberText
            NumberText = ""

        End If

        GroupIndex = GroupIndex + 1

    Loop

    ' Build result from highest group to lowest
    For I = 4 To 0 Step -1

        If Val(Groups(I)) > 0 Then

            GroupValue = Val(Groups(I))

            GroupWords = _
                ThreeDigitToPersian(GroupValue)

            If Result <> "" Then
                Result = Result & " " & PersianAnd()
            End If

            Result = Result & GroupWords

            If I > 0 Then
                Result = Result & " " & Scales(I)
            End If

        End If

    Next I

    PersianNumberToWords = Result

End Function


' ------------------------------------------------------------
' Convert numbers from 1 to 999
' ------------------------------------------------------------
Private Function ThreeDigitToPersian( _
    ByVal NumberValue As Long _
) As String

    Dim Units(0 To 19) As String
    Dim Tens(0 To 9) As String
    Dim Hundreds(0 To 9) As String

    Dim H As Long
    Dim R As Long
    Dim T As Long
    Dim U As Long

    Dim Result As String

    ' Units 1-19
    Units(0) = ""
    Units(1) = P("06CC") & P("06A9")
    Units(2) = P("062F") & P("0648")
    Units(3) = P("0633") & P("0647")
    Units(4) = P("0686") & P("0647") & P("0627") & P("0631")
    Units(5) = P("067E") & P("0646") & P("062C")
    Units(6) = P("0634") & P("0634")
    Units(7) = P("0647") & P("0641") & P("062A")
    Units(8) = P("0647") & P("0634") & P("062A")
    Units(9) = P("0646") & P("0647")
    Units(10) = P("062F") & P("0647")
    Units(11) = P("06CC") & P("0627") & P("0632") & P("062F") & P("0647")
    Units(12) = P("062F") & P("0648") & P("0627") & P("0632") & P("062F") & P("0647")
    Units(13) = P("0633") & P("06CC") & P("0632") & P("062F") & P("0647")
    Units(14) = P("0686") & P("0647") & P("0627") & P("0631") & P("062F") & P("0647")
    Units(15) = P("067E") & P("0627") & P("0646") & P("0632") & P("062F") & P("0647")
    Units(16) = P("0634") & P("0627") & P("0646") & P("0632") & P("062F") & P("0647")
    Units(17) = P("0647") & P("0641") & P("062F") & P("0647")
    Units(18) = P("0647") & P("062C") & P("062F") & P("0647")
    Units(19) = P("0646") & P("0648") & P("0632") & P("062F") & P("0647")

    ' Tens
    Tens(0) = ""
    Tens(1) = ""
    Tens(2) = P("0628") & P("06CC") & P("0633") & P("062A")
    Tens(3) = P("0633") & P("06CC")
    Tens(4) = P("0686") & P("0647") & P("0644")
    Tens(5) = P("067E") & P("0646") & P("062C") & P("0627") & P("0647")
    Tens(6) = P("0634") & P("0635") & P("062A")
    Tens(7) = P("0647") & P("0641") & P("062A") & P("0627") & P("062F")
    Tens(8) = P("0647") & P("0634") & P("062A") & P("0627") & P("062F")
    Tens(9) = P("0646") & P("0648") & P("062F")

    ' Hundreds
    Hundreds(0) = ""
    Hundreds(1) = P("0635") & P("062F")
    Hundreds(2) = P("062F") & P("0648") & P("06CC") & P("0633") & P("062A")
    Hundreds(3) = P("0633") & P("06CC") & P("0635") & P("062F")
    Hundreds(4) = P("0686") & P("0647") & P("0627") & P("0631") & P("0635") & P("062F")
    Hundreds(5) = P("067E") & P("0627") & P("0646") & P("0635") & P("062F")
    Hundreds(6) = P("0634") & P("0634") & P("0635") & P("062F")
    Hundreds(7) = P("0647") & P("0641") & P("062A") & P("0635") & P("062F")
    Hundreds(8) = P("0647") & P("0634") & P("062A") & P("0635") & P("062F")
    Hundreds(9) = P("0646") & P("0647") & P("0635") & P("062F")

    ' Split number
    H = NumberValue \ 100
    R = NumberValue Mod 100

    ' Hundreds
    If H > 0 Then
        Result = Hundreds(H)
    End If

    ' ۱-۱۹
    If R > 0 And R < 20 Then

        If Result <> "" Then
            Result = Result & " " & PersianAnd()
        End If

        Result = Result & Units(R)

    ' ۲۰-۹۹
    ElseIf R >= 20 Then

        T = R \ 10
        U = R Mod 10

        If Result <> "" Then
            Result = Result & " " & PersianAnd()
        End If

        Result = Result & Tens(T)

        If U > 0 Then
            Result = Result & " " & PersianAnd()
            Result = Result & Units(U)
        End If

    End If

    ThreeDigitToPersian = Result

End Function


' ------------------------------------------------------------
' Unicode character builder
'
' Example:
' P("06CC") = Persian Yeh
' ------------------------------------------------------------
Private Function P(ByVal HexCode As String) As String

    P = ChrW(CLng("&H" & HexCode))

End Function


' ------------------------------------------------------------
' Persian fixed words
' ------------------------------------------------------------

Private Function PersianAnd() As String
    PersianAnd = P("0648")
End Function

Private Function PersianZero() As String
    PersianZero = P("0635") & P("0641") & P("0631")
End Function

Private Function PersianThousand() As String
    PersianThousand = _
        P("0647") & P("0632") & P("0627") & _
        P("0631")
End Function

Private Function PersianMillion() As String
    PersianMillion = _
        P("0645") & P("06CC") & P("0644") & _
        P("06CC") & P("0648") & P("0646")
End Function

Private Function PersianBillion() As String
    PersianBillion = _
        P("0645") & P("06CC") & P("0644") & _
        P("06CC") & P("0627") & P("0631") & _
        P("062F")
End Function

Private Function PersianTrillion() As String
    PersianTrillion = _
        P("062A") & P("0631") & P("06CC") & _
        P("0644") & P("06CC") & P("0648") & _
        P("0646")
End Function

Private Function PersianNegativeWord() As String
    PersianNegativeWord = _
        P("0645") & P("0646") & P("0641") & P("06CC")
End Function


' ------------------------------------------------------------
' Persian Currency Names
' ------------------------------------------------------------

Public Function PersianRial() As String

    PersianRial = _
        P("0631") & P("06CC") & P("0627") & P("0644")

End Function


Public Function PersianToman() As String

    PersianToman = _
        P("062A") & P("0648") & P("0645") & P("0627") & P("0646")

End Function


Public Function PersianDinar() As String

    PersianDinar = _
        P("062F") & P("06CC") & P("0646") & P("0627") & P("0631")

End Function


' ------------------------------------------------------------
' Remove leading zeros
' ------------------------------------------------------------
Private Function RemoveLeadingZeros( _
    ByVal TextValue As String _
) As String

    Do While Len(TextValue) > 1 _
        And Left$(TextValue, 1) = "0"

        TextValue = Mid$(TextValue, 2)

    Loop

    If TextValue = "" Then
        TextValue = "0"
    End If

    RemoveLeadingZeros = TextValue

End Function

=AmountToWords(A1;PersianRial();"")

=AmountToWords(A1;PersianToman();"")