Convert number to text
2017-04-29 Functions 0 226
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 FunctionYou 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