Populate words

[VegasNath]

Is it possible to auto populate words in a cell based on the value of another (using formula or vba). eg:

A1: 26,562,744.52
A2: Twenty six million. five hundred sixty two thousand, seven ............... two pence.

[HansV]

The following is originally from Microsoft, modified to use pounds and pennies instead of dollars and cents.

Code: Select all

Option Explicit

Function NumberToText(ByVal MyNumber)
  Dim Pounds, Pence, Temp
  Dim DecimalPosition, Counter

  ReDim Position(9) As String
  Position(2) = " Thousand "
  Position(3) = " Million "
  Position(4) = " Billion "
  Position(5) = " Trillion "

  MyNumber = Trim(Str(MyNumber))

  DecimalPosition = InStr(MyNumber, ".")
  If DecimalPosition > 0 Then
    Pence = GetGetTens(Left(Mid(MyNumber, DecimalPosition + 1) & _
      "00", 2))
    MyNumber = Trim(Left(MyNumber, DecimalPosition - 1))
  End If

  Counter = 1
  Do While MyNumber <> ""
    Temp = GetHundreds(Right(MyNumber, 3))
    If Temp <> "" Then Pounds = Temp & Position(Counter) & Pounds
    If Len(MyNumber) > 3 Then
      MyNumber = Left(MyNumber, Len(MyNumber) - 3)
    Else
      MyNumber = ""
    End If
    Counter = Counter + 1
  Loop

  Select Case Pounds
    Case ""
      Pounds = "No Pounds"
    Case "One"
      Pounds = "One Pound"
    Case Else
      Pounds = Pounds & " Pounds"
  End Select

  Select Case Pence
    Case ""
      Pence = " and No Pence"
    Case "One"
      Pence = " and One Penny"
    Case Else
      Pence = " and " & Pence & " Pence"
  End Select

  NumberToText = Pounds & Pence
End Function

Function GetHundreds(ByVal MyNumber)
  Dim Result As String

  If Val(MyNumber) = 0 Then Exit Function
  MyNumber = Right("000" & MyNumber, 3)

  If Mid(MyNumber, 1, 1) <> "0" Then
    Result = GetDigit(Mid(MyNumber, 1, 1)) & " Hundred "
  End If

  If Mid(MyNumber, 2, 1) <> "0" Then
    Result = Result & GetGetTens(Mid(MyNumber, 2))
  Else
    Result = Result & GetDigit(Mid(MyNumber, 3))
  End If

  GetHundreds = Result
End Function

Function GetGetTens(TextoDecenas)
  Dim Result As String
  If Val(Left(TextoDecenas, 1)) = 1 Then
    Select Case Val(TextoDecenas)
      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
    Select Case Val(Left(TextoDecenas, 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
    Result = Result & GetDigit _
      (Right(TextoDecenas, 1))
  End If
  GetGetTens = Result
End Function

Function GetDigit(Digit)
  Select Case Val(Digit)
    Case 1: GetDigit = "One"
    Case 2: GetDigit = "Two"
    Case 3: GetDigit = "Three"
    Case 4: GetDigit = "Four"
    Case 5: GetDigit = "Five"
    Case 6: GetDigit = "Six"
    Case 7: GetDigit = "Seven"
    Case 8: GetDigit = "Eight"
    Case 9: GetDigit = "Nine"
    Case Else: GetDigit = ""
  End Select
End Function

Use:

=NumberToText(A1)

If you put the code in Personal.xls:

=Personal.xls!NumberToText(A1)

For Excel 2007, change Personal.xls to Personal.xlsb.

[VegasNath]

Many Thanks Hans, this will be very useful.

I am attempting to make a few modifications to:

a: incorporate comma seperators
b: not show "No pounds" or "No pence"

.... which has led me to a few problems:

a; Round amounts should not show comma seperators or extra spaces
b; Pence only should not begin " and "

I am attaching the results. Would you be able to suggest any correcting modifications?

NumbersToText.xls

Thanks

[HansV]

There are probably more efficient versions, but try this:

Code: Select all

Function NumberToText(ByVal MyNumber)
  Dim Pounds, Pence, Temp
  Dim DecimalPosition, Counter

  ReDim Position(9) As String
  Position(2) = " Thousand, "
  Position(3) = " Million, "
  Position(4) = " Billion, "
  Position(5) = " Trillion, "

  MyNumber = Trim(Str(MyNumber))

  DecimalPosition = InStr(MyNumber, ".")
  If DecimalPosition > 0 Then
    Pence = GetTens(Left(Mid(MyNumber, DecimalPosition + 1) & _
      "00", 2))
    MyNumber = Trim(Left(MyNumber, DecimalPosition - 1))
  End If

  Counter = 1
  Do While MyNumber <> ""
    Temp = GetHundreds(Right(MyNumber, 3))
    If Temp <> "" Then Pounds = Temp & Position(Counter) & Pounds
    If Len(MyNumber) > 3 Then
      MyNumber = Left(MyNumber, Len(MyNumber) - 3)
    Else
      MyNumber = ""
    End If
    Counter = Counter + 1
  Loop

  Pounds = Application.WorksheetFunction.Trim(Pounds)
  If Right(Pounds, 1) = "," Then
    Pounds = Left(Pounds, Len(Pounds) - 1)
  End If

  Select Case Pounds
    Case ""
      Pounds = ""
    Case "One"
      Pounds = "One Pound"
    Case Else
      Pounds = Pounds & " Pounds"
  End Select

  Select Case Pence
    Case ""
      Pence = ""
    Case "One"
      If Pounds = "" Then
        Pence = "One Penny"
      Else
        Pence = " and One Penny"
      End If
    Case Else
      If Pounds = "" Then
        Pence = Pence & " Pence"
      Else
        Pence = " and " & Pence & " Pence"
      End If
  End Select

  NumberToText = Pounds & Pence
End Function

Function GetHundreds(ByVal MyNumber)
  Dim Result As String

  If Val(MyNumber) = 0 Then Exit Function
  MyNumber = Right("000" & MyNumber, 3)

  If Mid(MyNumber, 1, 1) <> "0" Then
    Result = GetDigit(Mid(MyNumber, 1, 1)) & " Hundred "
  End If

  If Mid(MyNumber, 2, 1) <> "0" Then
    Result = Result & GetTens(Mid(MyNumber, 2))
  Else
    Result = Result & GetDigit(Mid(MyNumber, 3))
  End If

  GetHundreds = Result
End Function

Function GetTens(ByVal MyNumber)
  Dim Result As String
  If Val(Left(MyNumber, 1)) = 1 Then
    Select Case Val(MyNumber)
      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
    Select Case Val(Left(MyNumber, 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
    Result = Result & GetDigit _
      (Right(MyNumber, 1))
  End If
  GetTens = Result
End Function

Function GetDigit(Digit)
  Select Case Val(Digit)
    Case 1: GetDigit = "One"
    Case 2: GetDigit = "Two"
    Case 3: GetDigit = "Three"
    Case 4: GetDigit = "Four"
    Case 5: GetDigit = "Five"
    Case 6: GetDigit = "Six"
    Case 7: GetDigit = "Seven"
    Case 8: GetDigit = "Eight"
    Case 9: GetDigit = "Nine"
    Case Else: GetDigit = ""
  End Select
End Function

Note that financial applications often require explicit mention of "No Pounds" and "No Pence".

[VegasNath]

Thankyou Hans, I appreciate your help!

That all works apart from 20 / 30 / .....90 pence, which has a duplication of spaces. ?

[HansV]

Change the line

GetTens = Result

near the end of GetTens to

GetTens = Application.WorksheetFunction.Trim(Result)

[VegasNath]

Thanks.

Have a great weekend!

[VegasNath]

Hans, may I ask, would it be possible to use this function in Word? If so, how? (I'm not familiar with Word macro's)

[HansV]

The code itself will work in any Office application, but keep in mind that Word does not have worksheet formulas.

You can tell Word to format a field result as words using a simple formatting switch: the field code { =123456 \* CardText } will be displayed as one hundred twenty-three thousand four hundred fifty-six. This will only work for whole numbers up to 999,999.

[VegasNath]

OK, Thanks.

I'm not sure that I understand your response fully (I have an extremely limited knowledge and use for word). However, the 999,999 limitation will not match my requirement so I will look to see if I can convert to excel, or: prepare in excel and then copy to word.

Thanks Hans.

[HansV]

You can embed an Excel table in a Word document, or link to an Excel table in a Word document. In both cases, the table can use Excel's features, including worksheet formulas, custom functions etc.

[VegasNath]

OK, I'll keep that in mind as a possible approach. Many Thanks