سورس کد تبدیل عدد به حروف در اکسل

Global AlphaNumeric1(0 To 19) As String
Global AlphaNumeric2(1 To 9) As String
Global AlphaNumeric3(1 To 9) As String
Function AbH(Number As String)
Dim IsNegative As String
Dim DotPosition As Integer
Dim IntegerSegment As String
Dim DecimalSegment As String
Dim DotTxt, DecimalTxt As String
If Val(Number) > 0 Then IsNegative = "" Else IsNegative = "منفي "
DotPosition = InStr(1, Number, ".")
If Not (DotPosition) = 0 Then
    IntegerSegment = Left(Abs(Number), DotPosition - 1)
    DecimalSegment = Left(Right(Number, Len(Number) - DotPosition), 5)
If Val(IntegerSegment) <> 0 Then DotTxt = " مميز " Else DotTxt = ""
    Select Case Len(DecimalSegment)
    Case 1
        DecimalTxt = " دهم "
    Case 2
        DecimalTxt = " صدم "
    Case 3
        DecimalTxt = " هزارم "
    Case 4
        DecimalTxt = " ده هزارم "
    Case 5
        DecimalTxt = " صد هزارم "
    End Select
    AbH = IsNegative & Horof(IntegerSegment) & DotTxt & Horof(DecimalSegment) & DecimalTxt
    Exit Function
End If
AbH = IsNegative & Horof(Abs(Number))
End Function

Sub alphaset()
   Dim i%
   AlphaNumeric1(0) = ""
   AlphaNumeric1(1) = "يك"
   AlphaNumeric1(2) = "دو"
   AlphaNumeric1(3) = "سه"
   AlphaNumeric1(4) = "چهار"
   AlphaNumeric1(5) = "پنج"
   AlphaNumeric1(6) = "شش"
   AlphaNumeric1(7) = "هفت"
   AlphaNumeric1(8) = "هشت"
   AlphaNumeric1(9) = "نه"
   AlphaNumeric1(10) = "ده"
   AlphaNumeric1(11) = "يازده"
   AlphaNumeric1(12) = "دوازده"
   AlphaNumeric1(13) = "سيزده"
   AlphaNumeric1(14) = "چهارده"
   AlphaNumeric1(15) = "پانزده"
   AlphaNumeric1(16) = "شانزده"
   AlphaNumeric1(17) = "هفده"
   AlphaNumeric1(18) = "هيجده"
   AlphaNumeric1(19) = "نوزده"
   AlphaNumeric2(1) = "ده"
   AlphaNumeric2(2) = "بيست"
   AlphaNumeric2(3) = "سي"
   AlphaNumeric2(4) = "چهل"
   AlphaNumeric2(5) = "پنجاه"
   AlphaNumeric2(6) = "شصت"
   AlphaNumeric2(7) = "هفتاد"
   AlphaNumeric2(8) = "هشتاد"
   AlphaNumeric2(9) = "نود"
   AlphaNumeric3(1) = "يكصد"
   AlphaNumeric3(2) = "دويست"
   AlphaNumeric3(3) = "سيصد"
   AlphaNumeric3(4) = "چهارصد"
   AlphaNumeric3(5) = "پانصد"
   AlphaNumeric3(6) = "ششصد"
   AlphaNumeric3(7) = "هفتصد"
   AlphaNumeric3(8) = "هشتصد"
   AlphaNumeric3(9) = "نهصد"
End Sub
Function Horof(Number As String) As String
   alphaset
    Dim No As Currency, N As String
    
    On Error GoTo Horoferror
    
    No = CCur(Number)
    N = CStr(No)
    
    Select Case Len(N)
        Case 1 To 3:
                If N < 20 Then
                    Horof = AlphaNumeric1(N)
                ElseIf N < 100 Then
                    If N Mod 10 = 0 Then
                        Horof = AlphaNumeric2(N \ 10)
                    Else
                        Horof = AlphaNumeric2(N \ 10) & " و " & Horof(N Mod 10)
                    End If
                ElseIf N < 1000 Then
                    If N Mod 100 = 0 Then
                        Horof = AlphaNumeric3(N \ 100)
                    Else
                        Horof = AlphaNumeric3(N \ 100) & " و " & Horof(N Mod 100)
                    End If
                        
                End If
        Case 4 To 6:
                If (Right(N, 3)) = 0 Then
                   Horof = Horof(Left(N, Len(N) - 3)) & " هزار "
                Else
                    Horof = Horof(Left(N, Len(N) - 3)) & " هزار و " & Horof(Right(N, 3))
                End If
        Case 7 To 9:
                If (Right(N, 6)) = 0 Then
                   Horof = Horof(Left(N, Len(N) - 6)) & " ميليون "
                Else
                    Horof = Horof(Left(N, Len(N) - 6)) & " ميليون و " & Horof(Right(N, 6))
                End If
        Case Else:
                If (Right(N, 9)) = 0 Then
                   Horof = Horof(Left(N, Len(N) - 9)) & " ميليارد "
                Else
                    Horof = Horof(Left(N, Len(N) - 9)) & " ميليارد و " & Horof(Right(N, 9))
                End If
            
    End Select
    
    Exit Function
Horoferror:
    Horof = "#Error"
End Function