'FunctionFunction Arguments()
'myNumber, 'NumbermyNumber = Number to be converted to text
'OptionalOptional NumberSystem as Integer== DEFAULT Value = 2, '11 for International (Thousand,Million,Billion), 2 for Indian (Thousand,Lakh,Crore), Default Value 1
'OptionalOptional CurrencyConversion as Boolean = = DEFAULT Value = True"YES", _ TrueYes to convert the number to CURRENCYcurrency, False to convert the number to TextDefault Value Yes.
'OptionalOptional CurrSYMSingular as String = DEFAULT Value = "RUPEE", ''for'for example USD or US DOLLAR, INR or Indian Rupee for one unit of currency, Default Value Rupee
'OptionalOptional CurrSYMPlural as String = DEFAULT Value = "RUPEES", 'forfor example USDs or US DOLLARs, INRs or Indian Rupees for multiple units of currency, Default Value Rupees
'OptionalOptional FractionSize as Integer = DEFAULT Value = 100, _ 'forfor example 100 for one INR = 100 Paise, one USD = 100 Cents, Default value 100
'OptionalOptional FracSYMSingular as String = DEFAULT Value = "PAISA", 'forfor example Cent for US DOLLAR, Paisa for Indian Rupee for one unit of currency fraction, Default Value Paisa
'OptionalOptional FracSYMPlural as String = = DEFAULT Value = "PAISE", 'forfor example Cents for US DOLLAR, Paise for Indian Rupee for multiple units of currency fraction, Default Value Paise
'OptionalOptional TextStyle as Byte = = DEFAULT Value = 1 '11 for CurrencySYM and Amount, 2 for Amount and CurrencySYM, Default Value 1"
Option Explicit
Function TextCurrency(ByVal myNumber, Optional NumberSystem As Byte = 2, Optional CurrencyConversion As Boolean = True"YES", _
Optional CurrSYMSingular As String = "RUPEE", Optional CurrSYMPlural As String = "RUPEES", Optional FractionSize As Integer = 100, _
Optional FracSYMSingular As String = "PAISA", Optional FracSYMPlural As String = "PAISE", Optional TextStyle As Byte = 1)
'This is the Main function. Please don't miss private functions supporting it below.
'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 myNumberInt AsTemp, StringmyNumberInt, myNumberFrac As String
Dim, DecimalPlace As, IntegerCount, RUPEEs As String, PAISE As String
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) As String
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) As String
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) As String
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) As String
If Len(myNumber) = 0 Or IsNumeric(myNumber) = False Then
NumberINTtotext = ""
Exit Function
End If
Dim Temp As String,
Dim myNumberInt As String, myNumberInteger As String
Dim DecimalPlace As Byte, Count As Byte
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) As String
If Len(myNumber) = 0 Or Val(myNumber) = 0 Or IsNumeric(myNumber) = False Then
NumberINTtoINDtext = ""
Exit Function
End If
Dim Temp As String
Dim RUPEEs As String, Hundreds As StringPAISE
Dim DecimalPlace As Byte, Count As Byte
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) As String
Dim Temp As String, myNumberFrac As String, DecimalPlace As Byte, Count As Byte'___________________________________________________________
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
'______________________________________________
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", _
"True or 1"Yes to convert the number to currency, Else please enter False or 0"No" & vbCrLf & "Make sure the number is rounded to best suit the fraction size of the desired currency" & vbCrLf & "Default Value True"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
Edited as suggested by FreeMan in the answer.
