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

با افزونه پیوست شما میتوانید اعداد را در اکسل بحروف نمایش دهید.

Sub sumit()
    Dim mainWorkBook
    Set mainWorkBook = ActiveWorkbook
    intRows = mainWorkBook.Sheets("Main").UsedRange.Rows.Count
    'MsgBox intRows
    For i = 1 To intRows
    intValue = mainWorkBook.Sheets("Main").Range("A" & i)
       If intValue <> "" Then
            mainWorkBook.Sheets("Main").Range("B" & i) = d2a(intValue)
       End If
    Next
End Sub
Function d2a(strNumber)

    blnDecimalExist = False
    strNumber = CStr(strNumber)
    
    If InStr(1, strNumber, ".", vbTextCompare) > 0 Then
        arrSplit = Split(strNumber, ".")
        strNumber = arrSplit(0)
        strDecimal = arrSplit(1)
        
        If Len(strDecimal) > 2 Then
            strDecimal = Mid(strDecimal, 0, 2)
        End If
         
        If Len(strDecimal) > 0 And Len(strDecimal) < 2 Then
            strDecimalConversion = FnGetUnitDigit(strDecimal)
        End If
        If Len(strDecimal) > 1 And Len(strDecimal) < 3 Then
            strDecimalConversion = FnGetTensDigit(strDecimal)
        End If
        
        blnDecimalExist = True
        
    End If
    
    If Len(strNumber) > 0 And Len(strNumber) < 2 Then
        strTextConversion = FnGetUnitDigit(strNumber)
    End If
    If Len(strNumber) > 1 And Len(strNumber) < 3 Then
        strTextConversion = FnGetTensDigit(strNumber)
    End If
    If Len(strNumber) > 2 And Len(strNumber) < 4 Then
        strTextConversion = FnGetHundreds(strNumber)
    End If
    If Len(strNumber) > 3 And Len(strNumber) < 6 Then
        If Len(strNumber) = 4 Then
            strTextConversion = FnGetThousandsOne(strNumber)
        End If
        If Len(strNumber) = 5 Then
            strTextConversion = FnGetThousandsTwo(strNumber)
        End If
    End If
     If Len(strNumber) > 5 And Len(strNumber) < 8 Then
       If Len(strNumber) = 6 Then
            strTextConversion = FnGetLacsOne(strNumber)
        End If
        If Len(strNumber) = 7 Then
            strTextConversion = FnGetLacsTwo(strNumber)
        End If
    End If
    If Len(strNumber) > 7 And Len(strNumber) < 15 Then
       If Len(strNumber) = 8 Then
            strTextConversion = FnGetCroreOne(strNumber)
        End If
        If Len(strNumber) = 9 Then
            strTextConversion = FnGetCroreTwo(strNumber)
        End If
        If Len(strNumber) = 10 Then
            strTextConversion = FnGetCroreThree(strNumber)
        End If
        If Len(strNumber) = 11 Then
            strTextConversion = FnGetCroreFour(strNumber)
        End If
        If Len(strNumber) = 12 Then
            strTextConversion = FnGetCroreFive(strNumber)
        End If
        If Len(strNumber) = 13 Then
            strTextConversion = FnGetCroreSix(strNumber)
        End If
        If Len(strNumber) = 14 Then
            strTextConversion = FnGetCroreSeven(strNumber)
        End If
    End If
    
    
    If blnDecimalExist Then
        strTextConversion = "ریال " & strTextConversion & " و " & strDecimalConversion & " ***"
    Else
        strTextConversion = "ریال " & strTextConversion
    End If
    FnConvert = strTextConversion
End Function
Function FnGetCroreSeven(intN)
    Dim Str
    
    'temp = FnGetTensDigit(Left(intN, 3))
    'If temp <> "" Then
        Str = FnGetLacsTwo(Left(intN, 7)) & " بیلیارد " & FnGetLacsTwo(Right(intN, Len(intN) - 7))
    'Else
     '   Str = FnGetLacsTwo(Right(intN, Len(intN) - 3))
    'End If
    FnGetCroreSeven = Str
End Function

Function FnGetCroreSix(intN)
    Dim Str
    
    'temp = FnGetTensDigit(Left(intN, 3))
    'If temp <> "" Then
        Str = FnGetLacsOne(Left(intN, 6)) & " بیلیارد " & FnGetLacsTwo(Right(intN, Len(intN) - 6))
    'Else
     '   Str = FnGetLacsTwo(Right(intN, Len(intN) - 3))
    'End If
    FnGetCroreSix = Str
End Function

Function FnGetCroreFive(intN)
    Dim Str
    
    'temp = FnGetTensDigit(Left(intN, 3))
    'If temp <> "" Then
        Str = FnGetThousandsTwo(Left(intN, 5)) & " بیلیارد " & FnGetLacsTwo(Right(intN, Len(intN) - 5))
    'Else
     '   Str = FnGetLacsTwo(Right(intN, Len(intN) - 3))
    'End If
    FnGetCroreFive = Str
End Function

Function FnGetCroreFour(intN)
    Dim Str
    
    'temp = FnGetTensDigit(Left(intN, 3))
    'If temp <> "" Then
        Str = FnGetThousandsOne(Left(intN, 4)) & " بیلیارد " & FnGetLacsTwo(Right(intN, Len(intN) - 4))
    'Else
     '   Str = FnGetLacsTwo(Right(intN, Len(intN) - 3))
    'End If
    FnGetCroreFour = Str
End Function

Function FnGetCroreThree(intN)
    Dim Str
    
    'temp = FnGetTensDigit(Left(intN, 3))
    'If temp <> "" Then
        Str = FnGetHundreds(Left(intN, 3)) & " بیلیارد " & FnGetLacsTwo(Right(intN, Len(intN) - 3))
    'Else
     '   Str = FnGetLacsTwo(Right(intN, Len(intN) - 3))
    'End If
    FnGetCroreThree = Str
End Function

Function FnGetCroreTwo(intN)
    Dim Str
    
    temp = FnGetTensDigit(Left(intN, 2))
    If temp <> "" Then
        Str = FnGetTensDigit(Left(intN, 2)) & " بیلیارد " & FnGetLacsTwo(Right(intN, Len(intN) - 2))
    Else
        Str = FnGetLacsTwo(Right(intN, Len(intN) - 2))
    End If
    
    FnGetCroreTwo = Str
End Function

Function FnGetCroreOne(intN)
    Dim Str
     
    temp = FnGetUnitDigit(Left(intN, 1))
    If temp <> "" Then
        Str = FnGetUnitDigit(Left(intN, 1)) & " بیلیون " & FnGetLacsTwo(Right(intN, Len(intN) - 1))
    Else
        Str = FnGetLacsTwo(Right(intN, Len(intN) - 1))
    End If
    
     FnGetCroreOne = Str
End Function
Function FnGetLacsTwo(intN)
    Dim Str
    
    temp = FnGetTensDigit(Left(intN, 2))
    If temp <> "" Then
        Str = FnGetTensDigit(Left(intN, 2)) & " میلیارد " & FnGetThousandsTwo(Right(intN, Len(intN) - 2))
    Else
        Str = FnGetThousandsTwo(Right(intN, Len(intN) - 2))
    End If
    
    FnGetLacsTwo = Str
End Function
Function FnGetLacsOne(intN)
    Dim Str
     'Str = FnGetUnitDigit(Left(intN, 1)) & " میلیون " & FnGetThousandsTwo(Right(intN, Len(intN) - 1))
     
    temp = FnGetUnitDigit(Left(intN, 1))
    If temp <> "" Then
        Str = FnGetUnitDigit(Left(intN, 1)) & " میلیون " & FnGetThousandsTwo(Right(intN, Len(intN) - 1))
    Else
        Str = FnGetThousandsTwo(Right(intN, Len(intN) - 1))
    End If
    
    
     FnGetLacsOne = Str
End Function
Function FnGetThousandsTwo(intN)
    Dim Str
    'Str = FnGetTensDigit(Left(intN, 2)) & " هزار " & FnGetHundreds(Right(intN, Len(intN) - 2))
    
    temp = FnGetTensDigit(Left(intN, 2))
    If temp <> "" Then
        Str = FnGetTensDigit(Left(intN, 2)) & " هزار " & FnGetHundreds(Right(intN, Len(intN) - 2))
    Else
        Str = FnGetHundreds(Right(intN, Len(intN) - 2))
    End If
    
    
    FnGetThousandsTwo = Str
End Function
Function FnGetThousandsOne(intN)
    Dim Str
    'Str = FnGetUnitDigit(Left(intN, 1)) & " هزار " & FnGetHundreds(Right(intN, Len(intN) - 1))
    
    temp = FnGetUnitDigit(Left(intN, 1))
    If temp <> "" Then
        Str = FnGetUnitDigit(Left(intN, 1)) & " هزار " & FnGetHundreds(Right(intN, Len(intN) - 1))
    Else
        Str = FnGetHundreds(Right(intN, Len(intN) - 1))
    End If
    
    FnGetThousandsOne = Str
End Function
Function FnGetHundreds(intN)
    Dim Str
    temp = FnGetUnitDigit(Left(intN, 1))
    If temp <> "" Then
        Str = FnGetUnitDigit(Left(intN, 1)) & " صد " & FnGetTensDigit(Right(intN, 2))
    Else
        Str = FnGetTensDigit(Right(intN, 2))
    End If
    
    FnGetHundreds = Trim(Str)
End Function
Function FnGetTensDigit(intN)
    Dim Str
    If Left(intN, 1) = 1 Then
       Select Case Val(intN)
            Case 10: Str = "دو"
            Case 11: Str = "یازده"
            Case 12: Str = "دوازده"
            Case 13: Str = "سیزده"
            Case 14: Str = "چهارده"
            Case 15: Str = "پانزده"
            Case 16: Str = "شانزده"
            Case 17: Str = "هفده"
            Case 18: Str = "هجده"
            Case 19: Str = "نوزده"
        End Select
    Else
        Select Case Val(Left(intN, 1))
            Case 2: Str = "بیست"
            Case 3: Str = "سی"
            Case 4: Str = "چهل"
            Case 5: Str = "پنجاه"
            Case 6: Str = "شصت"
            Case 7: Str = "هفتاد"
            Case 8: Str = "هشتاد"
            Case 9: Str = "نود"
        End Select
        
        Str = Str & " " & FnGetUnitDigit(Right(intN, 1))
    End If
    
    FnGetTensDigit = Trim(Str)
End Function
Function FnGetUnitDigit(intN)

    Dim Str

    Select Case Val(intN)
        Case 1: Str = "یک"
        Case 2: Str = "دو"
        Case 3: Str = "سه"
        Case 4: Str = "چهار"
        Case 5: Str = "پنج"
        Case 6: Str = "شش"
        Case 7: Str = "هفت"
        Case 8: Str = "هشت"
        Case 9: Str = "نه"
    End Select
        FnGetUnitDigit = Trim(Str)
End Function