none
Spell Numbers Including Decimcal Places (3 Digits) RRS feed

  • Question

  • Hi,

    I want to spell the numbers like,

    1234.001 as "One Thousand Two Hundred Thirty Four And One "

    1234.010 as "One Thousand Two Hundred Thirty Four And Ten "

    1234.100 as "One Thousand Two Hundred Thirty Four And One Hundred "

    1234.110 as "One Thousand Two Hundred Thirty Four And One Hundred Ten "

    1234.101 as "One Thousand Two Hundred Thirty Four And One Hundred One "

    1234.121 as "One Thousand Two Hundred Thirty Four And One Hundred Twenty One "

    Could you please help me to fix this problem ?



    Wednesday, June 24, 2015 11:56 AM

Answers

  • =SpellNumber(INT(A1)) & " And " & SpellNumber(ROUND(MOD(A1,1)*1000,0))

    'http://support.microsoft.com/kb/213360
    Option Explicit
    
    Sub Example_SpellNumber()
      Debug.Print SpellNumber(1, , True, "Point")
    End Sub
    
    Function SpellNumber(ByVal MyNumber, _
        Optional ByVal SpellSingleDigitsBefore As Boolean, _
        Optional ByVal SpellSingleDigitsAfter As Boolean, _
        Optional ByVal DotWord As String, _
        Optional ByVal CurrencyBefore As String, _
        Optional ByVal CurrencyAfter As String)
      Dim DigitsBefore As String, DigitsAfter As String
      Dim Temp As String
      Dim i As Long, j As Long
      
      ReDim Place(9) As String
      Place(2) = " Thousand "
      Place(3) = " Million "
      Place(4) = " Billion "
      Place(5) = " Trillion "
      
      'Strip blanks
      If VarType(MyNumber) <> vbString Then MyNumber = Str(MyNumber)
      If InStr(MyNumber, " ") > 0 Then MyNumber = Replace$(MyNumber, " ", "")
      
      'Process decimal places first
      i = InStr(MyNumber, ".")
      If i > 0 Then
        If SpellSingleDigitsAfter Then
          DigitsAfter = Mid(MyNumber, i + 1)
          For j = 1 To Len(DigitsAfter)
            Temp = Temp & " " & GetDigit(Mid(DigitsAfter, j, 1), True)
          Next
          DigitsAfter = Temp
        Else
          DigitsAfter = " " & GetTens(Left(Mid(MyNumber, i + 1) & "00", 2))
        End If
        MyNumber = Trim(Left(MyNumber, i - 1))
      End If
      
      i = 1
      Do While MyNumber <> ""
        Temp = GetHundreds(Right(MyNumber, 3))
        If Temp <> "" Then DigitsBefore = Temp & Place(i) & DigitsBefore
        If Len(MyNumber) > 3 Then
          MyNumber = Left(MyNumber, Len(MyNumber) - 3)
        Else
          MyNumber = ""
        End If
        i = i + 1
      Loop
      
      'Add currency words if any
      If Len(CurrencyBefore) > 0 Then
        Select Case DigitsBefore
          Case ""
            DigitsBefore = "No " & CurrencyBefore & "s"
          Case "One"
            DigitsBefore = "One " & CurrencyBefore
          Case Else
            DigitsBefore = DigitsBefore & " " & CurrencyBefore & "s"
        End Select
      Else
        Select Case DigitsBefore
          Case ""
            DigitsBefore = "Zero"
        End Select
      End If
      If Len(CurrencyAfter) > 0 Then
        Select Case DigitsAfter
          Case ""
            DigitsAfter = " and No " & CurrencyAfter & "s"
          Case "One"
            DigitsAfter = " and One " & CurrencyAfter
          Case Else
            DigitsAfter = " and " & DigitsAfter & " " & CurrencyAfter
        End Select
      ElseIf Len(DotWord) Then
        DigitsAfter = " " & DotWord & DigitsAfter
      End If
      
      SpellNumber = DigitsBefore & DigitsAfter
      
      'Strip double blanks
      Do While InStr(SpellNumber, "  ") > 0
        SpellNumber = Replace(SpellNumber, "  ", " ")
      Loop
    End Function
    
    Function GetHundreds(ByVal MyNumber As String) As String
      'Converts a number from 100-999 into text
      Dim Result As String
      If Val(MyNumber) = 0 Then Exit Function
      MyNumber = Right("000" & MyNumber, 3)
      'Convert the hundreds place.
      If Mid(MyNumber, 1, 1) <> "0" Then
        Result = GetDigit(Mid(MyNumber, 1, 1)) & " Hundred "
      End If
      'Convert the tens and ones place.
      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 TensText As String) As String
      'Converts a number from 10 to 99 into text.
      Dim Result As String
      'If value between 10-19...
      If Val(Left(TensText, 1)) = 1 Then
        Select Case Val(TensText)
          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
        'If value between 20-99...
        Select Case Val(Left(TensText, 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
        'Retrieve ones place.
        Result = Result & GetDigit(Right(TensText, 1))
      End If
      GetTens = Result
    End Function
    
    Function GetDigit(ByVal Digit As String, _
        Optional ByVal SpellZero As Boolean) As String
      'Converts a number from 0 to 9 into text.
      Select Case Val(Digit)
        Case 0: If SpellZero Then GetDigit = "Zero"
        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"
      End Select
    End Function
    


    • Edited by Andreas Killer Wednesday, June 24, 2015 12:31 PM
    • Proposed as answer by ryguy72 Thursday, June 25, 2015 1:38 AM
    • Marked as answer by L.HlModerator Wednesday, July 1, 2015 8:25 AM
    Wednesday, June 24, 2015 12:31 PM

All replies

  • =SpellNumber(INT(A1)) & " And " & SpellNumber(ROUND(MOD(A1,1)*1000,0))

    'http://support.microsoft.com/kb/213360
    Option Explicit
    
    Sub Example_SpellNumber()
      Debug.Print SpellNumber(1, , True, "Point")
    End Sub
    
    Function SpellNumber(ByVal MyNumber, _
        Optional ByVal SpellSingleDigitsBefore As Boolean, _
        Optional ByVal SpellSingleDigitsAfter As Boolean, _
        Optional ByVal DotWord As String, _
        Optional ByVal CurrencyBefore As String, _
        Optional ByVal CurrencyAfter As String)
      Dim DigitsBefore As String, DigitsAfter As String
      Dim Temp As String
      Dim i As Long, j As Long
      
      ReDim Place(9) As String
      Place(2) = " Thousand "
      Place(3) = " Million "
      Place(4) = " Billion "
      Place(5) = " Trillion "
      
      'Strip blanks
      If VarType(MyNumber) <> vbString Then MyNumber = Str(MyNumber)
      If InStr(MyNumber, " ") > 0 Then MyNumber = Replace$(MyNumber, " ", "")
      
      'Process decimal places first
      i = InStr(MyNumber, ".")
      If i > 0 Then
        If SpellSingleDigitsAfter Then
          DigitsAfter = Mid(MyNumber, i + 1)
          For j = 1 To Len(DigitsAfter)
            Temp = Temp & " " & GetDigit(Mid(DigitsAfter, j, 1), True)
          Next
          DigitsAfter = Temp
        Else
          DigitsAfter = " " & GetTens(Left(Mid(MyNumber, i + 1) & "00", 2))
        End If
        MyNumber = Trim(Left(MyNumber, i - 1))
      End If
      
      i = 1
      Do While MyNumber <> ""
        Temp = GetHundreds(Right(MyNumber, 3))
        If Temp <> "" Then DigitsBefore = Temp & Place(i) & DigitsBefore
        If Len(MyNumber) > 3 Then
          MyNumber = Left(MyNumber, Len(MyNumber) - 3)
        Else
          MyNumber = ""
        End If
        i = i + 1
      Loop
      
      'Add currency words if any
      If Len(CurrencyBefore) > 0 Then
        Select Case DigitsBefore
          Case ""
            DigitsBefore = "No " & CurrencyBefore & "s"
          Case "One"
            DigitsBefore = "One " & CurrencyBefore
          Case Else
            DigitsBefore = DigitsBefore & " " & CurrencyBefore & "s"
        End Select
      Else
        Select Case DigitsBefore
          Case ""
            DigitsBefore = "Zero"
        End Select
      End If
      If Len(CurrencyAfter) > 0 Then
        Select Case DigitsAfter
          Case ""
            DigitsAfter = " and No " & CurrencyAfter & "s"
          Case "One"
            DigitsAfter = " and One " & CurrencyAfter
          Case Else
            DigitsAfter = " and " & DigitsAfter & " " & CurrencyAfter
        End Select
      ElseIf Len(DotWord) Then
        DigitsAfter = " " & DotWord & DigitsAfter
      End If
      
      SpellNumber = DigitsBefore & DigitsAfter
      
      'Strip double blanks
      Do While InStr(SpellNumber, "  ") > 0
        SpellNumber = Replace(SpellNumber, "  ", " ")
      Loop
    End Function
    
    Function GetHundreds(ByVal MyNumber As String) As String
      'Converts a number from 100-999 into text
      Dim Result As String
      If Val(MyNumber) = 0 Then Exit Function
      MyNumber = Right("000" & MyNumber, 3)
      'Convert the hundreds place.
      If Mid(MyNumber, 1, 1) <> "0" Then
        Result = GetDigit(Mid(MyNumber, 1, 1)) & " Hundred "
      End If
      'Convert the tens and ones place.
      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 TensText As String) As String
      'Converts a number from 10 to 99 into text.
      Dim Result As String
      'If value between 10-19...
      If Val(Left(TensText, 1)) = 1 Then
        Select Case Val(TensText)
          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
        'If value between 20-99...
        Select Case Val(Left(TensText, 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
        'Retrieve ones place.
        Result = Result & GetDigit(Right(TensText, 1))
      End If
      GetTens = Result
    End Function
    
    Function GetDigit(ByVal Digit As String, _
        Optional ByVal SpellZero As Boolean) As String
      'Converts a number from 0 to 9 into text.
      Select Case Val(Digit)
        Case 0: If SpellZero Then GetDigit = "Zero"
        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"
      End Select
    End Function
    


    • Edited by Andreas Killer Wednesday, June 24, 2015 12:31 PM
    • Proposed as answer by ryguy72 Thursday, June 25, 2015 1:38 AM
    • Marked as answer by L.HlModerator Wednesday, July 1, 2015 8:25 AM
    Wednesday, June 24, 2015 12:31 PM
  • VERY COOL!!!

    Knowledge is the only thing that I can give you, and still retain, and we are both better off for it.

    Thursday, June 25, 2015 1:38 AM
  • thnx too much , but this vb code only read two digits after Decimcal Places . ( find attach ) .
    Thursday, June 25, 2015 9:18 AM

  • Note: My Excel is a German edition, that's why the formula and the number in A1 appears different as in your Excel.


    • Edited by Andreas Killer Thursday, June 25, 2015 10:23 AM Wrong screen shot
    Thursday, June 25, 2015 10:22 AM
  • thnx too much , now is ok , I miss one step .
    Thursday, June 25, 2015 1:27 PM
  • I'm pleased to hear that it works.

    Would you please so kind and mark the post with the code as answer? So it would be easier to find the right answer for followers. Thank you.

    Andreas.
    Thursday, June 25, 2015 4:52 PM