Abstract
Sometimes you need to spell numbers in English words with Dollars/Cents or British Pound Sterling/Pence or European Euro/Cent. 12.31 would result in Twelve Dollars and Thirtyone Cents, for example.
Note: There are many faulty spellnumber versions circulating in the web. I suggest to test your preferred version with the inputs listed below:
Appendix – sbSpellNumber / sbInWorten Code
Please read my Disclaimer.
Private sNWord(0 To 28) As String
Private sHWord(1 To 4) As String
Function sbInWorten(ByVal sNumber As String) As String
sbInWorten = sbSpellNumber(sNumber, "German", "EUR")
End Function
Function sbSpellNumber(ByVal sNumber As String, _
Optional sLang As String = "English", _
Optional sCcy As String = "USD") As String
'Template was Microsoft's limited version:
'https://support.microsoft.com/de-de/help/213360/
'how-to-convert-a-numeric-value-into-english-words-in-excel
'This version informs the user about its limits.
'Source (EN): http://www.sulprobil.de/sbspellnumber_en/
'Source (DE): http://www.berndplumhoff.de/sbinworten_de/
'(C) (P) by Bernd Plumhoff 02-Mar-2018 PB V1.0
Dim Euros As String, cents As String
Dim Result As String, Temp As String
Dim DecimalPlace As Integer, Count As Integer
Dim Place(1 To 6) As String
Dim dNumber As Double
Dim prefix As String, suffix As String
Select Case sLang
Case "English"
Place(1) = ""
Place(2) = " Thousand "
Place(3) = " Million "
Place(4) = " Billion "
Place(5) = " Trillion "
Place(6) = " Mantissa not wide enough for this number "
sHWord(1) = ">>>>> Error (Absolute amount > 999999999999999)! <<<<<"
sHWord(2) = " (rounded)"
sHWord(3) = "Minus "
sHWord(4) = "and"
sNWord(0) = "zero"
sNWord(1) = "one"
sNWord(2) = "two"
sNWord(3) = "three"
sNWord(4) = "four"
sNWord(5) = "five"
sNWord(6) = "six"
sNWord(7) = "seven"
sNWord(8) = "eight"
sNWord(9) = "nine"
sNWord(10) = "ten"
sNWord(11) = "eleven"
sNWord(12) = "twelve"
sNWord(13) = "thirteen"
sNWord(14) = "fourteen"
sNWord(15) = "fifteen"
sNWord(16) = "sixteen"
sNWord(17) = "seventeen"
sNWord(18) = "eighteen"
sNWord(19) = "nineteen"
sNWord(20) = "twenty"
sNWord(21) = "thirty"
sNWord(22) = "fourty"
sNWord(23) = "fifty"
sNWord(24) = "sixty"
sNWord(25) = "seventy"
sNWord(26) = "eighty"
sNWord(27) = "ninety"
sNWord(28) = "hundred"
Case "German"
Place(1) = ""
Place(2) = " Tausend "
Place(3) = " Millionen "
Place(4) = " Milliarden "
Place(5) = " Billionen "
Place(6) = " Die Mantisse ist nicht groß genug für diese Zahl "
sHWord(1) = ">>>>> Fehler (Absolutbetrag > 999999999999999)! <<<<<"
sHWord(2) = " (gerundet)"
sHWord(3) = "Minus "
sHWord(4) = "und"
sNWord(0) = "null"
sNWord(1) = "ein"
sNWord(2) = "zwei"
sNWord(3) = "drei"
sNWord(4) = "vier"
sNWord(5) = "fünf"
sNWord(6) = "sechs"
sNWord(7) = "sieben"
sNWord(8) = "acht"
sNWord(9) = "neun"
sNWord(10) = "zehn"
sNWord(11) = "elf"
sNWord(12) = "zwölf"
sNWord(13) = "dreizehn"
sNWord(14) = "vierzehn"
sNWord(15) = "fünfzehn"
sNWord(16) = "sechzehn"
sNWord(17) = "siebzehn"
sNWord(18) = "achtzehn"
sNWord(19) = "neunzehn"
sNWord(20) = "zwanzig"
sNWord(21) = "dreißig"
sNWord(22) = "vierzig"
sNWord(23) = "fünfzig"
sNWord(24) = "sechzig"
sNWord(25) = "siebzig"
sNWord(26) = "achtzig"
sNWord(27) = "neunzig"
sNWord(28) = "hundert"
End Select
'Empty string = 0
If "" = sNumber Then
sNumber = "0"
End If
dNumber = sNumber + 0#
'If we cannot cope with it, tell the user!
If Abs(dNumber) > 999999999999999# Then
sbSpellNumber = sHWord(1)
Exit Function
End If
'If we have to round we present a suffix "(rounded)"
If Abs(dNumber - Round(dNumber, 2)) > 1E-16 Then
dNumber = Round(dNumber, 2)
suffix = sHWord(2)
End If
'Negative numbers get a prefix "Minus"
If dNumber < 0# Then
prefix = sHWord(3)
dNumber = -dNumber
sNumber = Right(sNumber, Len(sNumber) - 1)
End If
sNumber = Trim(Str(sNumber))
If Left(sNumber, 1) = "." Then
sNumber = "0" & sNumber
End If
DecimalPlace = InStr(sNumber, ".")
If DecimalPlace > 0 Then
cents = GetTens(Left(Mid(sNumber, DecimalPlace + 1) & "00", 2), _
sLang, sCcy)
sNumber = Trim(Left(sNumber, DecimalPlace - 1))
End If
Count = 1
Do While sNumber <> ""
Temp = GetHundreds(Right(sNumber, 3), sLang, sCcy)
If Temp <> "" Then
If Euros <> "" And sLang = "German" Then
Euros = Temp & Place(Count) & " " & _
sHWord(4) & " " & Euros
Else
Euros = Temp & Place(Count) & Euros
End If
End If
If Len(sNumber) > 3 Then
sNumber = Left(sNumber, Len(sNumber) - 3)
Else
sNumber = ""
End If
Count = Count + 1
Loop
Select Case sCcy
Case "EUR"
Select Case Euros
Case ""
Euros = sNWord(0) & " Euros"
Case sNWord(1)
Euros = sNWord(1) & " Euro"
Case Else
Euros = Euros & " Euros"
End Select
Select Case cents
Case ""
cents = " " & sHWord(4) & " " & sNWord(0) & " Cents"
Case sNWord(1)
cents = " " & sHWord(4) & " " & sNWord(1) & " Cent"
Case Else
cents = " " & sHWord(4) & " " & cents & " Cents"
End Select
Case "GBP"
Select Case Euros
Case ""
Euros = sNWord(0) & " Pounds"
Case sNWord(1)
Euros = sNWord(1) & " Pound"
Case Else
Euros = Euros & " Pounds"
End Select
Select Case cents
Case ""
cents = " " & sHWord(4) & " " & sNWord(0) & " Pence"
Case sNWord(1)
cents = " " & sHWord(4) & " " & sNWord(1) & " Penny"
Case Else
cents = " " & sHWord(4) & " " & cents & " Pence"
End Select
Case "USD"
Select Case Euros
Case ""
Euros = sNWord(0) & " Dollars"
Case sNWord(1)
Euros = sNWord(1) & " Dollar"
Case Else
Euros = Euros & " Dollars"
End Select
Select Case cents
Case ""
cents = " " & sHWord(4) & " " & sNWord(0) & " Cents"
Case sNWord(1)
cents = " " & sHWord(4) & " " & sNWord(1) & " Cent"
Case Else
cents = " " & sHWord(4) & " " & cents & " Cents"
End Select
End Select
Temp = UCase(Replace(Euros & cents, " ", " "))
Select Case sLang
Case "English"
Temp = Application.WorksheetFunction.Proper(Temp)
Temp = Replace(Temp, " And ", " and ")
Case "German"
Temp = Application.WorksheetFunction.Proper(Temp)
Temp = Replace(Temp, "Ein Millionen", "Eine Million")
Temp = Replace(Temp, "Ein Milliarden", "Eine Milliarde")
Temp = Replace(Temp, "Ein Billionen", "Eine Billion")
Temp = Replace(Temp, "Dollars", "Dollar")
Temp = Replace(Temp, "Cents", "Cent")
Temp = Replace(Temp, "Pounds", "Pfund")
Temp = Replace(Temp, "Pound", "Pfund")
Temp = Replace(Temp, "Euros", "Euro")
Temp = Replace(Temp, "Pence", "Pennies")
Temp = Replace(Temp, " Und ", " und ")
End Select
sbSpellNumber = prefix & Temp & suffix
End Function
Private Function GetHundreds(ByVal sNumber, _
Optional sLang As String = "English", _
Optional sCcy As String = "USD") As String
Dim Result As String
If Val(sNumber) = 0 Then Exit Function
sNumber = Right("000" & sNumber, 3)
If Mid(sNumber, 1, 1) <> "0" Then
Result = GetDigit(Mid(sNumber, 1, 1)) _
& sNWord(28)
If Mid(sNumber, 2, 2) <> "00" Then
Result = Result & sHWord(4)
End If
End If
If Mid(sNumber, 2, 1) <> "0" Then
Result = Result & GetTens(Mid(sNumber, 2), sLang, sCcy)
ElseIf Mid(sNumber, 3, 1) <> "0" Then
Result = Result & GetDigit(Mid(sNumber, 3))
End If
GetHundreds = Result
End Function
Private Function GetTens(TensText As String, _
Optional sLang As String = "English", _
Optional sCcy As String = "USD")
Dim Result As String
Result = ""
If Val(Left(TensText, 1)) = 1 Then '10-19...
If Val(TensText) > 9 And Val(TensText) < 20 Then
GetTens = sNWord(Val(TensText))
End If
Exit Function
Else '20-99...
If Val(Left(TensText, 1)) > 1 And _
Val(Left(TensText, 1)) < 10 Then
Result = sNWord(18 + Val(Left(TensText, 1)))
Else
Result = GetDigit(Right(TensText, 1))
End If
If Right(TensText, 1) <> "0" And Left(TensText, 1) <> "0" Then
Select Case sLang
Case "German"
Result = GetDigit(Right(TensText, 1)) & _
sHWord(4) & Result
Case "English"
Result = Result & GetDigit(Right(TensText, 1))
End Select
End If
End If
GetTens = Result
End Function
Private Function GetDigit(Digit As String) As String
If Val(Digit) < 10 Then
GetDigit = sNWord(Val(Digit))
Else
GetDigit = ""
End If
End Function
Download
Please read my Disclaimer.
sbSpellNumber.xlsm [29 KB Excel file, open and use at your own risk]