Macro to convert a number to text (English only)

[John Google]

The macro shown below will convert any Long number to the text
equivalent (both +ve and -ve).

Thanks must be given to:

http://exceltips.vitalnews.com/Pages/T0351_Numbers_Spelled_Out.html

who have the original version of this function.

The original version was limited to +ve numbers between 1 and 999999.
As such, it did not handle millions (which I wanted).

I've changed the macro to handle both millions and billions. As it was
easy to do, I also added the functionality to ahndle -ve number (as it
simply adds a 'Minus' string before the number).

A minor change I made to the original code was to add the word 'and'
after hundreds. 'Seven Hundred and Seventy Three' sounds better than
'Seven Hundred Seventry Three'. Most automated cheques add the 'and'
where it would naturally seem appropriate. This also occurs after
thousands, e.g. 'Seventenn thousand and Thirty Five'

I've tested various numbers and it seems OK as far as I can see. I've
not tried all 4 billion numbers so there may be errors in the macro
which I don't know about.

Anyway, I hope it is useful to you....

To use this macro (after you have added it to your workbook) simply
type into cell B1:

=NumberToWords(A1)

Then enter any number between -2147483647 and 2147483647 into A1. Cell
B1 will show the English text representation of your number.

The following functions need to be added to a module in the VBE for
the current workbook. (I hope you know how to do this!).

John.








' This function will convert all numbers between -2147483647 and
2147483647
' to a text string representing the number in plain English words.

Function NumberToWords(vCVal)

Dim sWords As String
Dim lNumber As Long

sWords = ""
If IsNumeric(vCVal) Then
' If the number cannot fit into a long (-2147483647 to
2147483647) CLng
' will throw an error #Value which will be returned back to the
caller.
If vCVal = CLng(vCVal) Then
lNumber = CLng(vCVal)
Select Case lNumber
Case -2147483647 To -1000000000
sWords = "Minus " + SetBillions(Abs(lNumber))
Case -1000000000 To -1000000
sWords = "Minus " + SetMillions(Abs(lNumber))
Case -999999 To -1
sWords = "Minus " + SetThousands(Abs(lNumber))
Case 0
sWords = "Zero"
Case 1 To 999999
sWords = SetThousands(lNumber)
Case 1000000 To 999999999
sWords = SetMillions(lNumber)
Case 1000000000 To 2147483647
sWords = SetBillions(lNumber)
End Select
NumberToWords = sWords
Else
' Is a number but not a whole number (e.g. 123.45)
NumberToWords = CVErr(xlErrValue)
End If
Else
' Source is not a number
NumberToWords = CVErr(xlErrValue)
End If

End Function
Private Function SetOnes(ByVal lNumber As Integer) As String
Dim OnesArray(9) As String
OnesArray(1) = "One"
OnesArray(2) = "Two"
OnesArray(3) = "Three"
OnesArray(4) = "Four"
OnesArray(5) = "Five"
OnesArray(6) = "Six"
OnesArray(7) = "Seven"
OnesArray(8) = "Eight"
OnesArray(9) = "Nine"
SetOnes = OnesArray(lNumber)
End Function
Private Function SetTens(ByVal lNumber As Integer) As String
Dim TensArray(9) As String
TensArray(1) = "Ten"
TensArray(2) = "Twenty"
TensArray(3) = "Thirty"
TensArray(4) = "Forty"
TensArray(5) = "Fifty"
TensArray(6) = "Sixty"
TensArray(7) = "Seventy"
TensArray(8) = "Eighty"
TensArray(9) = "Ninety"
Dim TeensArray(9) As String
TeensArray(1) = "Eleven"
TeensArray(2) = "Twelve"
TeensArray(3) = "Thirteen"
TeensArray(4) = "Fourteen"
TeensArray(5) = "Fifteen"
TeensArray(6) = "Sixteen"
TeensArray(7) = "Seventeen"
TeensArray(8) = "Eighteen"
TeensArray(9) = "Nineteen"
Dim iTemp1 As Integer
Dim iTemp2 As Integer
Dim sTemp As String
iTemp1 = Int(lNumber / 10)
iTemp2 = lNumber Mod 10
sTemp = TensArray(iTemp1)
If (iTemp1 = 1 And iTemp2 > 0) Then
sTemp = TeensArray(iTemp2)
Else
If (iTemp1 > 1 And iTemp2 > 0) Then
sTemp = sTemp + " " + SetOnes(iTemp2)
End If
End If
SetTens = sTemp
End Function
Private Function SetHundreds(ByVal lNumber As Integer) As String
Dim iTemp1 As Integer
Dim iTemp2 As Integer
Dim sTemp As String
iTemp1 = Int(lNumber / 100)
iTemp2 = lNumber Mod 100
If iTemp1 > 0 Then sTemp = SetOnes(iTemp1) + " Hundred"
If iTemp2 > 0 Then
If sTemp > "" Then sTemp = sTemp + " and "
If iTemp2 < 10 Then sTemp = sTemp + SetOnes(iTemp2)
If iTemp2 > 9 Then sTemp = sTemp + SetTens(iTemp2)
End If
SetHundreds = sTemp
End Function
Private Function SetThousands(ByVal lNumber As Long) As String
Dim iTemp1 As Integer
Dim iTemp2 As Integer
Dim sTemp As String
iTemp1 = Int(lNumber / 1000)
iTemp2 = lNumber Mod 1000
If iTemp1 > 0 Then sTemp = SetHundreds(iTemp1) + " Thousand"
If iTemp2 > 0 Then
If sTemp > "" Then sTemp = sTemp + " "
If iTemp2 < 100 And iTemp1 > 0 Then sTemp = sTemp + "and "
sTemp = sTemp + SetHundreds(iTemp2)
End If
SetThousands = sTemp
End Function
Private Function SetMillions(ByVal lNumber As Long) As String
Dim iTemp1 As Long
Dim iTemp2 As Long
Dim sTemp As String
iTemp1 = Int(lNumber / 1000000)
iTemp2 = lNumber Mod 1000000
If iTemp1 > 0 Then sTemp = SetThousands(iTemp1) + " Million"
If iTemp2 > 0 Then
If sTemp > "" Then sTemp = sTemp + " "
sTemp = sTemp + SetThousands(iTemp2)
End If
SetMillions = sTemp
End Function
Private Function SetBillions(ByVal lNumber As Long) As String
Dim iTemp1 As Long
Dim iTemp2 As Long
Dim sTemp As String
iTemp1 = Int(lNumber / 1000000000)
iTemp2 = lNumber Mod 1000000000
If iTemp1 > 0 Then sTemp = SetMillions(iTemp1) + " Billion"
If iTemp2 > 0 Then
If sTemp > "" Then sTemp = sTemp + " "
sTemp = sTemp + SetMillions(iTemp2)
End If
SetBillions = sTemp
End Function

 

[John Google]

Quick Fix!

I've noticed an error with the Billions and Millions. If you hade
1,000,000,017 it was dispalyed as 'One Billion Seventeen'. This was
similar for 1,000,017.

I decided to add the 'and' to this situation so, the functions below
should replace the originals.

Private Function SetMillions(ByVal lNumber As Long) As String
Dim iTemp1 As Long
Dim iTemp2 As Long
Dim sTemp As String
iTemp1 = Int(lNumber / 1000000)
iTemp2 = lNumber Mod 1000000
If iTemp1 > 0 Then sTemp = SetThousands(iTemp1) + " Million"
If iTemp2 > 0 Then
If sTemp > "" Then sTemp = sTemp + " "
If iTemp2 < 100 And iTemp1 > 0 Then sTemp = sTemp + "and "
sTemp = sTemp + SetThousands(iTemp2)
End If
SetMillions = sTemp
End Function

Private Function SetBillions(ByVal lNumber As Long) As String
Dim iTemp1 As Long
Dim iTemp2 As Long
Dim sTemp As String
iTemp1 = Int(lNumber / 1000000000)
iTemp2 = lNumber Mod 1000000000
If iTemp1 > 0 Then sTemp = SetMillions(iTemp1) + " Billion"
If iTemp2 > 0 Then
If sTemp > "" Then sTemp = sTemp + " "
If iTemp2 < 100 And iTemp1 > 0 Then sTemp = sTemp + "and "
sTemp = sTemp + SetMillions(iTemp2)
End If
SetBillions = sTemp
End Function

 

[Pete_UK]

John,

thanks for sharing this - there are certainly a lot of requests for
such a function on the newsgroups.

You mentioned printing cheques in your first post, but you don't seem
to handle pence (or cents) - most printed cheques I receive have the
decimal part in numeric form after the words, so is this something you
intend to build in?

Pete

 

[Bob Phillips]

There are loads already, including
http://www.xldynamic.com/source/xld.xlFAQ0004.html

--
---
HTH

Bob

(there's no email, no snail mail, but somewhere should be gmail in my addy)

 

[John Google]

The following is a modified version of one of the routines
(SpellNumber) linked by Bob Phillips.

It handles decimal points as you requested.

I modified it for the following reasons:

1. If 0 was passed it failed. It now returns Zero.
2. There were double spaces between some words.
3. If you passed a parameter for the cents parameter along with a
whole number, the result was something like 'Twleve Dollars Only
Cents'.
4. 'and' is used after hundreds, thousands etc as appropraite as I
prefer it that way. The code shows how this can be deleted if
required.
5. I allow for negative numbers.
6. I got rid of the fraction parameter as I don't need it.
7. I got rid of the Proper function as I wanted 'and' to remain
lowercase.
8. I changed Dollars and Cents to Pounds and Pence as the defaults.

John.


'
' SpellNumber
'

Function SpellNumber(ByVal n As Double, _
Optional ByVal useword As Boolean = True, _
Optional ByVal ccy As String = "Pounds", _
Optional ByVal cents As String = "Pence", _
Optional ByVal join As String = "and") As String

Dim myLength As Long
Dim i As Long
Dim myNum As Long
Dim Remainder As Long
Dim negative As Boolean

If n = 0# Then
SpellNumber = "Zero" & IIf(useword, " " & ccy, "")
Else
SpellNumber = ""
negative = n < 0#
If negative Then
n = n * -1#
End If

Remainder = Round(100 * (n - Int(n)), 0)

myLength = Int(Application.Log10(n) / 3)

For i = myLength To 0 Step -1
myNum = Int(n / 10 ^ (i * 3))
n = n - myNum * 10 ^ (i * 3)
If myNum > 0 Then
SpellNumber = SpellNumber & MakeWord(Int(myNum)) & _
Choose(i + 1, "", "Thousand ", "Million ", "Billion ",
"Trillion ")
' Add "and" between previous value and the following if it is
< 100 - CAN BE REMOVED BY DELETING THE FOLLOWING THREE LINES
If SpellNumber <> "" And n >= 1# And n < 100# Then
SpellNumber = SpellNumber & "and "
End If
End If
Next i
If SpellNumber <> "" Then
SpellNumber = Trim(SpellNumber & IIf(useword, ccy & " ", ""))
End If
If Remainder > 0 Then
SpellNumber = SpellNumber + Format(Remainder, " 00")
If cents <> "" Then
SpellNumber = SpellNumber + " " + cents
End If
Else
SpellNumber = SpellNumber + " Only"
End If
If negative Then
SpellNumber = "Minus " + SpellNumber
End If

End If
End Function
Function MakeWord(ByVal inValue As Long) As String

Dim unitWord, tenWord
Dim n As Long
Dim unit As Long, ten As Long, hund As Long

unitWord = Array("", "One", "Two", "Three", "Four", _
"Five", "Six", "Seven", "Eight", _
"Nine", "Ten", "Eleven", "Twelve", _
"Thirteen", "Fourteen", "Fifteen", _
"Sixteen", "Seventeen", "Eighteen", "Nineteen")

tenWord = Array("", "Ten", "Twenty", "Thirty", "Forty", _
"Fifty", "Sixty", "Seventy", "Eighty", "Ninety")

MakeWord = ""
n = inValue
If n = 0 Then MakeWord = "Zero"
hund = n \ 100
If hund > 0 Then MakeWord = MakeWord & MakeWord(Int(hund)) &
"Hundred"
n = n - hund * 100
If n > 0 And MakeWord <> "" Then
MakeWord = MakeWord + " and "
End If
If n < 20 Then
ten = n
MakeWord = MakeWord & unitWord(ten) & " "
Else
ten = n \ 10
MakeWord = MakeWord & tenWord(ten) & " "
unit = n - ten * 10
If unit > 0 Then
MakeWord = MakeWord & unitWord(unit) & " "
End If
End If

End Function