No problem yet with the code.
Here is a function that can be saved as add in and used as UDF in Microsoft excel to convert a number to text. For example, 4556.45
to RUPEES Four Thousand Five Hundred Fifty Six & PAISE Forty Five
(Defaults being set to Indian Rupee). But the function can be adopted to any currency through suitable parameters making it very flexible. Submitting for review. Kindly suggest any modifications required. Thank you.
Function Arguments
myNumber = Number to be converted to text
Optional NumberSystem = DEFAULT Value = 2, 1 for International (Thousand,Million,Billion), 2 for Indian (Thousand,Lakh,Crore), Default Value 1
Optional CurrencyConversion = DEFAULT Value = "YES", _ Yes to convert the number to currency, Default Value Yes.
Optional CurrSYMSingular = DEFAULT Value = "RUPEE", 'for example USD or US DOLLAR, INR or Indian Rupee for one unit of currency, Default Value Rupee
Optional CurrSYMPlural = DEFAULT Value = "RUPEES", for example USDs or US DOLLARs, INRs or Indian Rupees for multiple units of currency, Default Value Rupees
Optional FractionSize = DEFAULT Value = 100, _ for example 100 for one INR = 100 Paise, one USD = 100 Cents, Default value 100
Optional FracSYMSingular = DEFAULT Value = "PAISA", for example Cent for US DOLLAR, Paisa for Indian Rupee for one unit of currency fraction, Default Value Paisa
Optional FracSYMPlural = DEFAULT Value = "PAISE", for example Cents for US DOLLAR, Paise for Indian Rupee for multiple units of currency fraction, Default Value Paise
Optional TextStyle = DEFAULT Value = 1 1 for CurrencySYM and Amount, 2 for Amount and CurrencySYM, Default Value 1"
Main function and other private functions supporting it are as below.
Function TextCurrency(ByVal myNumber, Optional NumberSystem = 2, Optional CurrencyConversion = "YES", _
Optional CurrSYMSingular = "RUPEE", Optional CurrSYMPlural = "RUPEES", Optional FractionSize = 100, _
Optional FracSYMSingular = "PAISA", Optional FracSYMPlural = "PAISE", Optional TextStyle = 1)
'Refer to following webpage for fractional units and sizes of different currencies
'https://en.wikipedia.org/wiki/List_of_circulating_currencies
' Maximum fraction size is 1000 (eg. OMR).
Dim Temp, myNumberInt, myNumberFrac, DecimalPlace, Count, RUPEEs, PAISE
If Val(myNumber) <> 0 Then
myNumber = Trim(Str(myNumber))
DecimalPlace = InStr(myNumber, ".")
End If
If DecimalPlace > 0 Then
myNumberInt = Trim(Left(myNumber, DecimalPlace - 1))
myNumberFrac = Trim(Mid(myNumber, DecimalPlace + 1))
If UCase(CurrencyConversion) = "YES" Then
If FractionSize <= 1000 Then myNumberFrac = Left(myNumberFrac & "000", 3)
If FractionSize <= 100 Then myNumberFrac = Left(myNumberFrac & "00", 2)
If FractionSize <= 10 Then myNumberFrac = Left(myNumberFrac & "0", 1)
End If
Else
myNumberInt = myNumber
End If
If NumberSystem = 2 Then
If Val(myNumberFrac) <> 0 Then
TextCurrency = NumberINTtoINDtext(myNumberInt) & " POINT " & NumberFRACtotext(myNumber)
Else
TextCurrency = NumberINTtoINDtext(myNumberInt)
End If
Else
If Val(myNumberFrac) <> 0 Then
TextCurrency = NumberINTtotext(myNumberInt) & " POINT " & NumberFRACtotext(myNumber)
Else
TextCurrency = NumberINTtotext(myNumberInt)
End If
End If
If UCase(CurrencyConversion) = "YES" Then
If NumberSystem = 2 Then
If Val(myNumberFrac) <> 0 Then
RUPEEs = NumberINTtoINDtext(myNumberInt)
PAISE = NumberINTtotext(myNumberFrac)
Else
RUPEEs = NumberINTtoINDtext(myNumberInt)
End If
Else
If Val(myNumberFrac) <> 0 Then
RUPEEs = NumberINTtotext(myNumberInt)
PAISE = NumberINTtotext(myNumberFrac)
Else
RUPEEs = NumberINTtotext(myNumberInt)
End If
End If
If Val(myNumber) = 0 Then TextCurrency = CurrSYMSingular & " " & "ZERO"
If TextStyle = 1 Then
Select Case RUPEEs
Case ""
RUPEEs = ""
Case "One"
RUPEEs = CurrSYMSingular & " One"
Case Else
RUPEEs = CurrSYMPlural & " " & RUPEEs
End Select
Select Case PAISE
Case ""
PAISE = ""
Case "One"
If RUPEEs = "" Then
PAISE = FracSYMSingular & " One"
Else
PAISE = " & " & FracSYMSingular & " One"
End If
Case Else
If RUPEEs = "" Then
PAISE = FracSYMPlural & " " & PAISE
Else
PAISE = " & " & FracSYMPlural & " " & PAISE
End If
End Select
Else
Select Case RUPEEs
Case ""
RUPEEs = ""
Case "One"
RUPEEs = "One " & CurrSYMSingular
Case Else
RUPEEs = RUPEEs & " " & CurrSYMPlural
End Select
Select Case PAISE
Case ""
PAISE = ""
Case "One"
If RUPEEs = "" Then
PAISE = "One " & FracSYMSingular
Else
PAISE = " & One " & FracSYMSingular
End If
Case Else
If RUPEEs = "" Then
PAISE = PAISE & " " & FracSYMPlural
Else
PAISE = " & " & PAISE & " " & FracSYMPlural
End If
End Select
End If
TextCurrency = RUPEEs & PAISE
End If
End Function
'___________________________________________________________
Private Function ConvertHundreds(ByVal myNumber)
Dim Result As String
' Exit if there is nothing to convert.
If Val(myNumber) = 0 Then Exit Function
' Append leading zeros to number.
myNumber = Right("000" & myNumber, 3)
'Debug.Print myNumber
' Do we have a hundreds place digit to convert?
If Left(myNumber, 1) <> "0" Then
Result = ConvertDigit(Left(myNumber, 1)) & " Hundred "
End If
' Do we have a tens place digit to convert?
If Mid(myNumber, 2, 1) <> "0" Then
Result = Result & ConvertTens(Mid(myNumber, 2))
Else
' If not, then convert the ones place digit.
Result = Result & ConvertDigit(Mid(myNumber, 3))
End If
ConvertHundreds = Trim(Result)
End Function
'___________________________________________________________
Private Function ConvertTens(ByVal MyTens)
Dim Result As String
' Is value between 10 and 19?
If Val(Left(MyTens, 1)) = 1 Then
Select Case Val(MyTens)
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
' .. otherwise it's between 20 and 99.
Select Case Val(Left(MyTens, 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
' Convert ones place digit.
Result = Result & ConvertDigit(Right(MyTens, 1))
End If
ConvertTens = Result
End Function
'___________________________________________________________
Private Function ConvertDigit(ByVal MyDigit)
Select Case Val(MyDigit)
Case 1: ConvertDigit = "One"
Case 2: ConvertDigit = "Two"
Case 3: ConvertDigit = "Three"
Case 4: ConvertDigit = "Four"
Case 5: ConvertDigit = "Five"
Case 6: ConvertDigit = "Six"
Case 7: ConvertDigit = "Seven"
Case 8: ConvertDigit = "Eight"
Case 9: ConvertDigit = "Nine"
Case Else: ConvertDigit = ""
End Select
End Function
'___________________________________________________________
Private Function NumberINTtotext(ByVal myNumber)
If Len(myNumber) = 0 Or IsNumeric(myNumber) = False Then
NumberINTtotext = ""
Exit Function
End If
Dim Temp
Dim myNumberInt, myNumberInteger
Dim DecimalPlace, Count
ReDim Place(9) As String
Place(2) = " Thousand "
Place(3) = " Million "
Place(4) = " Billion "
Place(5) = " Trillion "
' Convert MyNumber to a string, trimming extra spaces.
myNumber = Trim(Str(myNumber))
' Find decimal place.
DecimalPlace = InStr(myNumber, ".")
' If we find decimal place...
If DecimalPlace > 0 Then
myNumberInt = Trim(Left(myNumber, DecimalPlace - 1))
Else
myNumberInt = Trim(myNumber)
End If
If Val(myNumberInt) <> 0 Then
Count = 1
Do While myNumberInt <> ""
' Convert last 3 digits of MyNumber to English GBP.
Temp = ConvertHundreds(Right(myNumberInt, 3))
If Temp <> "" Then myNumberInteger = Temp & Place(Count) & myNumberInteger
If Len(myNumberInt) > 3 Then
' Remove last 3 converted digits from MyNumber.
myNumberInt = Left(myNumberInt, Len(myNumberInt) - 3)
Else
myNumberInt = ""
End If
Count = Count + 1
Loop
Else
myNumberInteger = "ZERO"
End If
NumberINTtotext = myNumberInteger
If Val(myNumber) = 0 Then NumberINTtotext = "ZERO"
End Function
'___________________________________________________________
Private Function NumberINTtoINDtext(ByVal myNumber)
If Len(myNumber) = 0 Or Val(myNumber) = 0 Or IsNumeric(myNumber) = False Then
NumberINTtoINDtext = ""
Exit Function
End If
Dim Temp
Dim RUPEEs, PAISE
Dim DecimalPlace, Count
ReDim Place(9) As String
Place(2) = " Thousand "
Place(3) = " Lac "
Place(4) = " Crore "
'Place(5) = " Arawb "
'Place(6) = " Kharawb "
'Place(7) = " Neel "
myNumber = Trim(Str(myNumber))
DecimalPlace = InStr(myNumber, ".")
If DecimalPlace > 0 Then
myNumber = Trim(Left(myNumber, DecimalPlace - 1))
End If
Do
Count = 2
If Len(myNumber) > 0 Then
Hundreds = ConvertHundreds(Right(myNumber, WorksheetFunction.Min(3, Len(myNumber))))
RUPEEs = Hundreds & RUPEEs
myNumber = Left(myNumber, Len(myNumber) - WorksheetFunction.Min(3, Len(myNumber)))
End If
Do While Count < 4
Temp = ConvertHundreds(Right(myNumber, WorksheetFunction.Min(2, Len(myNumber))))
If Temp <> "" Then RUPEEs = Temp & Place(Count) & RUPEEs
myNumber = Left(myNumber, Len(myNumber) - WorksheetFunction.Min(2, Len(myNumber)))
Count = Count + 1
Loop
If Len(myNumber) <> 0 And Count = 4 Then RUPEEs = " Crore " & RUPEEs
Loop While Val(Len(myNumber)) > 0
NumberINTtoINDtext = RUPEEs
End Function
'___________________________________________________________
Private Function NumberFRACtotext(ByVal myNumber)
Dim Temp, myNumberFrac, myNumberFraction, DecimalPlace, Count
If Len(myNumber) = 0 Or IsNumeric(myNumber) = False Then
NumberFRACtotext = ""
Exit Function
End If
' Convert MyNumber to a string, trimming extra spaces.
myNumber = Trim(Str(myNumber))
' Find decimal place.
DecimalPlace = InStr(myNumber, ".")
' If we find decimal place...
If DecimalPlace > 0 Then
myNumberFrac = Trim(Mid(myNumber, DecimalPlace + 1))
Else
NumberFRACtotext = "ZERO"
Exit Function
End If
Count = DecimalPlace + 1
Temp = ""
Do While Val(Mid(myNumber, Count, 1)) = 0
Temp = Temp & "ZERO "
Count = Count + 1
Loop
Do While Count <> Len(myNumber) + 1
If Val(Mid(myNumber, Count, 1)) = 0 Then
Temp = Temp & "ZERO "
Else
Temp = Temp & ConvertDigit(Val(Mid(myNumber, Count, 1))) & " "
End If
Count = Count + 1
Loop
NumberFRACtotext = Temp
End Function
After installing the function as add-in and before using the function, run this procedure to see the parameter descriptions in the function dialogue box. Better to save such procedures in personal excel book and to make it run on excel start.
Sub AddUDFToCustomCategory()
Application.MacroOptions Macro:="TextCurrency", Description:="Converts number to text", _
ArgumentDescriptions:=Array("Number to be converted to text", _
"1 for International (Thousand,Million,Billion)," & vbCrLf & "2 for Indian (Thousand,Lakh,Crore)," & vbCrLf & "Default Value 2", _
"Yes to convert the number to currency, Else please enter No" & vbCrLf & "Make sure the number is rounded to best suit the fraction size of the desired currency" & vbCrLf & "Default Value Yes", _
"for example USD or US DOLLAR, INR or Indian Rupee for one unit of currency," & vbCrLf & "Default Value Rupee", _
"for example USDs or US DOLLARs, INRs or Indian Rupees for multiple units of currency," & vbCrLf & "Default Value Rupees", _
"for example 100" & vbCrLf & "for one INR = 100 Paise, one USD = 100 Cents, One OMR = 1000 Baizas" & vbCrLf & "Default value 100", _
"for example Cent for US DOLLAR, Paisa for Indian Rupee for one unit of currency fraction," & vbCrLf & "Default Value Paisa", _
"for example Cents for US DOLLAR, Paise for Indian Rupee for multiple units of currency fraction," & vbCrLf & "Default Value Paise", _
"1 for CurrencySYM and Amount, for eample USD One Hundred Fifty," & vbCrLf & "2 for Amount and CurrencySYM, for eample One Hundred Fifty USD" & vbCrLf & "Default Value 1")
End Sub