Convert number to text
2017-04-29 Functions 0 652
The code below can be put into a new code module and then be used to convert a number to text, e.g. 9999 = nine thousand ninehundredandninetynine.
English and Norwegian is supported, other languages can easily be added.
Option Explicit
' updated 2017-04-29 by OPE, http://erlandsendata.no
' this module contains code necessary to convert a numeric value to text
' handles English and Norwegian but can easliy be extended or converted to most languages
' add supported languages by translating or adding text labels in the procedure PopulateStrings
' this module has only one public function: GetNumberAsText(dblNumber, [blnCurrency], [lngLanguage])
' dblNumber: any integer or decimal number supported by the Double data type
' blnCurrence: default = False, can optionally be set to True to include currency information in the returned text
' lngLanguage: default = current system language, can optionally be set to a language code defined in the procedure PopulateStrings
' module level variables
Private strInteger As String, strIntegers As String, strDecimal As String, strDecimals As String
Private strAnd As String, strComma As String, strMinus As String, strAltOne As String
Private varNumbers10 As Variant, varNumbers20 As Variant, varLabel As Variant, varLabels As Variant
Private Sub PopulateStrings(Optional lngLanguage As Long = -1)
' updated 2017-04-28 by OPE
' this procedure can be updated with new text labels for new languages
If lngLanguage < 1 Then
lngLanguage = Application.International(xlCountrySetting)
End If
' when adding or changing languages it is recommended to use the same country code numbers returned by Application.International(xlCountrySetting)
Select Case lngLanguage
Case 47 ' norwegian
strInteger = "krone" ' label for integer = 1
strIntegers = "kroner" ' label for other integers
strDecimal = "øre" ' label for decimal = 1
strDecimals = "øre" ' label for other decimals
strAnd = "og" ' label for AND
strComma = "komma" ' label for COMMA
strMinus = "minus" ' label for negative values
strAltOne = "ett" ' alternative label for 1 used for single hundreds and single thousands only
varNumbers10 = Array("ti", "tjue", "tretti", "førti", "femti", "seksti", "sytti", "åtti", "nitti", "hundre") ' labels for 10 units
varNumbers20 = Array("null", "en", "to", "tre", "fire", "fem", "seks", "syv", "åtte", "ni", "ti", "elleve", "tolv", "tretten", "fjorten", "femten", "seksten", "sytten", "atten", "nitten") ' labels for units 1 - 19
varLabel = Array("tusen", "million", "milliard", "trillion", "kvadrillion", "kvintillion", "sekstillion", "septillion") ' labels for 1 unit
varLabels = Array("tusen", "millioner", "milliarder", "trillioner", "kvadrillioner", "kvintillioner", "sekstillioner", "septillioner") ' labels for other units
Case Else ' default language, english
strInteger = "dollar" ' label for integer = 1
strIntegers = "dollars" ' label for other integers
strDecimal = "cent" ' label for decimal = 1
strDecimals = "cents" ' label for other decimals
strAnd = "and" ' label for AND
strComma = "comma" ' label for COMMA
strMinus = "minus" ' label for negative values
strAltOne = "one" ' alternative label for 1 used for single hundreds and single thousands only
varNumbers10 = Array("ten", "twenty", "thirty", "forty", "fifty", "sixty", "seventy", "eighty", "ninety", "hundred") ' labels for 10 units
varNumbers20 = Array("zero", "one", "two", "three", "four", "five", "six", "seven", "eight", "nine", "ten", "eleven", "twelve", "thirteen", "fourteen", "fifteen", "sixteen", "seventeen", "eighteen", "nineteen") ' labels for units 1 - 19
varLabel = Array("thousand", "million", "billion", "trillion", "quadrillion", "quintillion", "sextillion", "septillion") ' labels for 1 unit
varLabels = Array("thousands", "millions", "billions", "trillions", "quadrillions", "quintillions", "sextillions", "septillions") ' labels for other units
End Select
End Sub
Function GetNumberAsText(dblNumber As Double, Optional blnCurrency As Boolean = False, Optional lngLanguage As Long = -1) As String
' updated 2017-04-28 by OPE
' returns dblNumber as a text, optionally for a different language defined in PopulateStrings
' if blnCurrency is True then the text returned will contain information about currency (e.g. dollars or krone) as defined in PopulateStrings
' if lngLanguage is < 1 then the system country setting will be used to determine the language
' if lngLanguage is >= 1 then the function will try to return text in the language specified if it exists in PopulateStrings
' if the language code is not specified in PopulateStrings then the default language defined in PopulateStrings will be used
Dim blnNegative As Boolean, strNumber As String, strResult As String, dblDecimals As Double, strDecimal As String
Dim lngDigitGroups As Long, varGroup() As Variant, lngCount As Long, i As Long
Application.Volatile ' remove this line if you don't want this function to calculate all the time when used as a worksheet function
PopulateStrings lngLanguage
blnNegative = dblNumber < 0
' code for the integer part of dblNumber
lngCount = Len(Format(Fix(Abs(dblNumber)), "0")) ' count of digits in the integer part of dblNumber
Do While lngCount Mod 3 <> 0
lngCount = lngCount + 1
Loop
lngDigitGroups = lngCount / 3 ' count of digit groups
ReDim varGroup(1 To lngDigitGroups, 1 To 2) ' digit groups and value
strNumber = Replace(Space(lngCount), " ", "0") ' create required number format
strNumber = Format(Fix(Abs(dblNumber)), strNumber) ' apply number format
For i = 1 To lngDigitGroups
varGroup(i, 1) = CLng(Mid(strNumber, (i * 3 - 2), 3)) ' remember group digits
varGroup(i, 2) = varGroup(i, 1) ' remember group value
Next i
' convert each digit group to text
For i = 1 To lngDigitGroups
varGroup(i, 1) = Text100(CLng(varGroup(i, 2)), lngDigitGroups - i + 1, lngDigitGroups, lngLanguage)
Next i
If Len(varGroup(1, 1)) = 0 Then
varGroup(1, 1) = varNumbers20(LBound(varNumbers20)) ' add label for zero values
End If
' create output string
strResult = vbNullString
For i = 1 To lngDigitGroups
strResult = Trim(strResult & varGroup(i, 1)) & " "
Next i
If blnCurrency Then ' add currency label
If varGroup(lngDigitGroups, 2) = 1 Then
strResult = strResult & strInteger ' currency label for 1 unit
Else
strResult = strResult & strIntegers ' currency label for other units
End If
End If
strResult = Trim(strResult)
' code for the decimal part of dblNumber
dblDecimals = Abs(dblNumber - Fix(dblNumber))
If dblDecimals > 0 Then ' has decimals
strNumber = "0." & Replace(Space(Len(dblDecimals) - 2), " ", "0") ' create required number format
strNumber = Format(dblDecimals, strNumber) ' apply number format
strNumber = Mid(strNumber, 3) ' skip stuff before decimal
strNumber = RTrimChar(strNumber, "0")
Select Case Len(strNumber)
Case 1
strDecimal = NumberItemsToText(strNumber, " ", lngLanguage)
Case 2
If CLng(strNumber) < 10 Then
strDecimal = NumberItemsToText(strNumber, " ", lngLanguage)
Else
strDecimal = Text100(CLng(strNumber), 1, 1, lngLanguage)
End If
Case Else
strDecimal = NumberItemsToText(strNumber, " ", lngLanguage)
End Select
If blnCurrency Then
strResult = strResult & " " & strAnd & " " ' add "AND" to the label
Else
strResult = strResult & " " & strComma & " " ' add "COMMA" to the label
End If
strResult = strResult & strDecimal
If blnCurrency Then
If Len(strNumber) = 2 And CLng(strNumber) = 1 Then
strResult = strResult & " " & strDecimal ' add currency label for decimal part
Else
strResult = strResult & " " & strDecimals ' add currency label for decimal part
End If
End If
End If
If blnNegative Then
strResult = strMinus & " " & strResult ' add negative label if required
End If
GetNumberAsText = Trim(strResult)
End Function
Private Function Text100(lngNumber As Long, lngDigitGroup As Long, lngDigitGroupsCount As Long, Optional lngLanguage As Long = -1) As String
' updated 2017-04-28 by OPE
' returns the text label for lngNumber >=1 and <=999
' lngDigitGroup: the digit group for which lngNumber belongs.
' lngDigitGroupsCount: count of digit groups in the original number.
Dim strResult As String, lngHundred As Long, lngUpToHundred As Long, lngPart As Long, lngOffset As Long
If lngNumber < 1 Or lngNumber >= 1000 Then Exit Function
If Not IsArray(varLabel) Then
PopulateStrings lngLanguage
End If
lngHundred = CLng(Left((Format(Abs(lngNumber), "000")), 1)) ' count of hundreds in lngNumber
lngUpToHundred = CLng(Right((Format(Abs(lngNumber), "000")), 2)) ' value less than 100 in lngNumber
strResult = vbNullString
Select Case lngUpToHundred
Case 1 To 19
strResult = Text20(lngUpToHundred, lngDigitGroup = 2, lngLanguage) ' get text label
Case 20 To 99
lngPart = lngUpToHundred Mod 10 ' value less than 10 in lngNumber
strResult = Text10(CLng(Left((Format(lngUpToHundred, "00")), 1)), lngLanguage) & Text20(lngPart, lngDigitGroup = 2 And lngUpToHundred = 1, lngLanguage) ' get text label
End Select
If lngHundred > 0 Then
If lngUpToHundred > 0 Then
strResult = strAnd & strResult ' add "AND" to the label
End If
strResult = Text20(lngHundred, True, lngLanguage) & varNumbers10(UBound(varNumbers10)) & strResult ' add "HUNDRED" to the label
Else
If lngDigitGroup < lngDigitGroupsCount Then
strResult = strAnd & " " & strResult ' add "AND " to the label
End If
End If
lngOffset = 1 - LBound(varLabel)
lngPart = lngDigitGroup - 1 ' calculate index number for digit group label
If lngPart > 0 And lngPart <= UBound(varLabel) Then
If lngNumber = 1 Then
strResult = strResult & " " & Trim(varLabel(lngPart - lngOffset)) ' add digit group label
Else
strResult = strResult & " " & Trim(varLabels(lngPart - lngOffset)) ' add digit group label
End If
End If
strResult = Replace(strResult, "ttt", "tt") ' remove triple t's (norwegian spelling exception)
Text100 = strResult ' apply function result
End Function
Private Function Text20(lngNumber As Long, Optional blnAltOne As Boolean = False, Optional lngLanguage As Long = -1) As String
' updated 2017-04-28 by OPE
' returns the text label for lngNumber >=0 and <=19
Dim strResult As String, lngOffset As Long
If Not IsArray(varNumbers10) Then
PopulateStrings lngLanguage
End If
If lngNumber >= 1 And lngNumber <= 19 Then
If lngNumber = 1 And blnAltOne Then
strResult = strAltOne
Else
lngOffset = 1 - LBound(varNumbers20)
strResult = varNumbers20(lngNumber + 1 - lngOffset) ' first array item is zero, last is nineteen
End If
Text20 = Trim(strResult)
End If
End Function
Private Function Text10(lngNumber As Long, Optional lngLanguage As Long = -1) As String
' updated 2017-04-28 by OPE
' returns the text label for lngNumber * 10
Dim lngOffset As Long
If Not IsArray(varNumbers10) Then
PopulateStrings lngLanguage
End If
If lngNumber >= 1 And lngNumber <= 10 Then
lngOffset = 1 - LBound(varNumbers10)
Text10 = Trim(varNumbers10(lngNumber - lngOffset)) ' first array item is ten, last is hundred
End If
End Function
Private Function NumberItemsToText(varNumber As Variant, Optional strDelimiter As String = " ", Optional lngLanguage As Long = -1) As String
' updated 2017-04-28 by OPE
' returns a text with the individual numbers in varNumber
Dim strResult As String, strText As String, blnMinus As Boolean, i As Long, j As Long, lngOffset As Long
If Not IsArray(varNumbers20) Then
PopulateStrings lngLanguage
End If
If TypeName(varNumber) = "String" Then
blnMinus = Left(Trim(varNumber), 1) = "-"
If blnMinus Then
strText = Mid(Trim(varNumber), 2)
Else
strText = Trim(varNumber)
End If
Else
blnMinus = varNumber < 0
strText = Format(Abs(varNumber), "0")
End If
lngOffset = 1 - LBound(varNumbers20)
For i = 1 To Len(strText)
j = CLng(Mid(strText, i, 1))
strResult = strResult & varNumbers20(j + 1 - lngOffset) & strDelimiter ' first array item is zero
Next i
If Len(strResult) > 0 And Len(strDelimiter) > 0 Then
strResult = Left(strResult, Len(strResult) - Len(strDelimiter))
End If
If blnMinus Then
strResult = strMinus & " " & strResult
End If
NumberItemsToText = strResult
End Function
Private Function RTrimChar(strText As String, strChar As String) As String
' updated 2017-04-28 by OPE
Dim strResult As String
If Len(strText) = 0 Then Exit Function
If Len(strChar) = 0 Then Exit Function
strResult = strText
Do While Right(strResult, Len(strChar)) = strChar
strResult = Left(strResult, Len(strResult) - Len(strChar))
Loop
RTrimChar = strResult
End Function
You can use the code above like this in a worksheet:=GetNumberAsText(A1)
=GetNumberAsText(A1;True)
=GetNumberAsText(A1;True;47)
You can use the code above like this in your code:
strText = GetNumberAsText(Range("A1").Value)
strText = GetNumberAsText(Range("A1").Value, True)
strText = GetNumberAsText(Range("A1").Value, True, 47)
Click here to download this file.
Updated: 2017-04-29 Requires: XL2007 File size: 35 kB
This is an updated code example from 2006-05-06