VBA Express : Multiple Apps - Change number into complete words, including currency names

Multiple Apps

Change number into complete words, including currency names

Ease of Use

Easy

Version tested with

2002

Submitted by:

alimcpill

Description:

Given a number and currency units, this function will return the amount in words (e.g. £5.37 -> five pounds and thirty-seven pence)

Discussion:

We needed to send an email where we had to include an amount written in words. While the number itself could be added to the email through code, we had to pop up an input box for the user to manually type the number in words. This code removed that step. Note that the currency names are passed as parameters, so you are not limited to good old pounds and pence!

Code:

instructions for use

			Option Explicit 
 
Private m_dicNums      As Dictionary 
Private m_lngHundreds  As Long 
Private m_lngLast      As Long 
Private m_strBigUnit   As String 
Private m_strSmallUnit As String 
 
Public Function Num2Words(varAmount As Variant, _ 
    strBigUnit As String, _ 
    strSmallUnit As String) 
     
    Dim strRv           As String 'return value
    Dim objRe           As RegExp 'regular expression object
    Dim objMatches      As MatchCollection 'stores results of reg expression test
    Dim strNum          As String 'stores string representation of number being converted
    Dim lngSignificance As Long 'significance of part of number being converted
    Dim strTemp         As String 'temporary string variable
    Dim dblAmount       As Double 'stores value passed as a double (as opposed to variant)
     
    Set objRe = New RegExp 
     
    FillDic 
     
    m_strBigUnit = strBigUnit 
    m_strSmallUnit = strSmallUnit 
     
    If IsNumeric(varAmount) Then 
        dblAmount = Abs(CDbl(Round(varAmount, 2))) 
         
        If dblAmount > 0 Then 
             
            strNum = CStr(dblAmount) 
             
             'remove commas and erroneous chars just in case (though there won't be any)
            objRe.Pattern = "[^\d\.]" 
            strNum = objRe.Replace(strNum, "") 
             
            objRe.Pattern = "(\d*)\.(\d+)$" 
            Set objMatches = objRe.Execute(strNum) 
             
             'see if we have any pence
            If objMatches.Count = 1 Then 
                 'have pence. Make the end of the amount first.
                strRv = ConvertPart(objMatches(0).SubMatches(1), -1) & " " & strSmallUnit 
                 'now trim off the decimal data.
                strNum = objMatches(0).SubMatches(0) 
                If CLng(strNum) = 0 Then 
                     'trim off the 'and'
                    strRv = Right(strRv, Len(strRv) - 4) 
                End If 
            End If 
             
             'now we need to go through from the right, taking three digits
             'at a time.
             
             'only continue if there actually are any big units
            If CLng(strNum) > 0 Then 
                 
                lngSignificance = 1 
                 
                Do 
                    strTemp = ConvertPart(CStr(CLng(Right(strNum, 3))), lngSignificance) 
                    If strTemp <> "" And Left(strRv, 1) <> " " Then 
                        strRv = strTemp & " " & strRv 
                    ElseIf strTemp <> "" Then 
                        strRv = strTemp & strRv 
                    End If 
                    If Len(strNum) - 3 < 1 Then 
                        Exit Do 
                    End If 
                    strNum = Left(strNum, Len(strNum) - 3) 
                    lngSignificance = lngSignificance * 1000 
                Loop 
                 
                strNum = CStr(dblAmount) 
                strRv = Trim(strRv) 
                 'just correct if only 1 big unit
                If strNum = "1" Or Left(strNum, 2) = "1." Then 
                     'replace the big unit with the big unit minus the last letter!
                    objRe.Pattern = strBigUnit 
                    strRv = objRe.Replace(strRv, Left(strBigUnit, Len(strBigUnit) - 1)) 
                End If 
            End If 
        Else 
            strRv = "zero" 
        End If 
    Else 
        strRv = "Could not convert" 
    End If 
     
     'clean up, kill objects
    Set objMatches = Nothing 
    Set objRe = Nothing 
     
    Num2Words = strRv 
     
End Function 
 
 'converts a 3 digit number according to its significance in the whole
 'number.
Private Function ConvertPart(strNum As String, lngSignificance As Long) As String 
     
    Dim strRv As String 
     
    Select Case lngSignificance 
    Case -1 
        If Len(strNum) = 1 Then 
            strRv = "and " & ConvertNum(strNum & "0") 
        Else 
            strRv = "and " & ConvertNum(strNum) 
        End If 
    Case 1 
         'strRv = ConvertNum(strNum) & " " & m_dicNums(lngSignificance) & " pounds"
        If ConvertNum(strNum) <> "" Then 
            strRv = ConvertNum(strNum) & " " & m_strBigUnit 
        Else 
            strRv = m_strBigUnit 
        End If 
        m_lngHundreds = CLng(strNum) 
        m_lngLast = m_lngHundreds 
    Case 1000 
        If ConvertNum(strNum) <> "" Then 
            strRv = ConvertNum(strNum) & " " & m_dicNums(lngSignificance) 
        End If 
        If m_lngHundreds < 100 And m_lngHundreds <> 0 Then 
            strRv = strRv & " and" 
        ElseIf m_lngHundreds >= 100 Then 
            strRv = strRv & "," 
        End If 
        m_lngLast = CLng(strNum) 
    Case Else 
        If ConvertNum(strNum) <> "" Then 
            strRv = ConvertNum(strNum) & " " & m_dicNums(lngSignificance) 
            If m_lngLast <> 0 Then 
                strRv = strRv & "," 
            End If 
        End If 
        m_lngLast = CLng(strNum) 
    End Select 
     
    ConvertPart = strRv 
     
End Function 
 
 'converts a number in the range 0-999
Private Function ConvertNum(strNum As String) As String 
     
    Dim strRv As String 
     
    If CLng(strNum) > 0 Then 
         
        Select Case Len(strNum) 
        Case 1 
            strRv = m_dicNums(CLng(strNum)) 
        Case 2 
            If m_dicNums.Exists(CLng(strNum)) Then 
                strRv = m_dicNums(CLng(strNum)) 
            Else 
                strRv = m_dicNums(CLng(Left(strNum, 1) & "0")) & "-" & m_dicNums(CLng(Right(strNum, 1))) 
            End If 
        Case 3 
            If m_dicNums.Exists(CLng(strNum)) Then 
                strRv = "one " & m_dicNums(CLng(strNum)) 
            Else 
                strRv = m_dicNums(CLng(Left(strNum, 1))) & " hundred" 
                If CLng(Right(strNum, 2)) > 0 Then 
                    If m_dicNums.Exists(CLng(Right(strNum, 2))) Then 
                        strRv = strRv & " and " & m_dicNums(CLng(Right(strNum, 2))) 
                    Else 
                        strRv = strRv & " and " & m_dicNums(CLng(Mid(strNum, 2, 1) & "0")) & "-" & m_dicNums(CLng(Right(strNum, 1))) 
                    End If 
                End If 
            End If 
        End Select 
         
    End If 
     
    ConvertNum = strRv 
     
End Function 
 
 'feel free to change the spelling if you disagree with mine!
Private Sub FillDic() 
     
    Set m_dicNums = New Dictionary 
     
    m_dicNums(0) = "zero" 
    m_dicNums(1) = "one" 
    m_dicNums(2) = "two" 
    m_dicNums(3) = "three" 
    m_dicNums(4) = "four" 
    m_dicNums(5) = "five" 
    m_dicNums(6) = "six" 
    m_dicNums(7) = "seven" 
    m_dicNums(8) = "eight" 
    m_dicNums(9) = "nine" 
     
    m_dicNums(10) = "ten" 
    m_dicNums(11) = "eleven" 
    m_dicNums(12) = "twelve" 
    m_dicNums(13) = "thirteen" 
    m_dicNums(14) = "fourteen" 
    m_dicNums(15) = "fifteen" 
    m_dicNums(16) = "sixteen" 
    m_dicNums(17) = "seventeen" 
    m_dicNums(18) = "eighteen" 
    m_dicNums(19) = "nineteen" 
     
    m_dicNums(20) = "twenty" 
    m_dicNums(30) = "thirty" 
    m_dicNums(40) = "forty" 
    m_dicNums(50) = "fifty" 
    m_dicNums(60) = "sixty" 
    m_dicNums(70) = "seventy" 
    m_dicNums(80) = "eighty" 
    m_dicNums(90) = "ninety" 
     
    m_dicNums(100) = "hundred" 
    m_dicNums(1000) = "thousand" 
    m_dicNums(1000000) = "million" 
    m_dicNums(1000000000) = "billion" 
    m_dicNums(1000000000000#) = "trillion" 
     
     
End Sub

How to use:

This is instructions of how to use this as a worksheet function in excel, but can be used as a function in any VBA or VB code.
Start a new workbook in Excel.
Open the VBA editor with alt+F11
Now need to add some references to external libraries, which should be installed by default.
-From the menu, choose 'Tools->References'
-Scroll down the list and put a tick next to the following items: 'Microsoft Scripting Runtime' and 'Microsoft VBScript Regular Expressions x.y", where x.y is a version number, as long as it is 1.0 or above it should be fine.
-Click 'OK'
From the menu, choose 'Insert->Module'.
Copy and paste the above code into the module.
Check all the references by choosing 'Debug->Compile VBAProject' from the menu. If all is well this will complete quickly with no error messages.
Close the Visual Basic editor

Test the code:

Select any sheet of the workbook you have just created.
In Cell A2 enter any number.
In Cell A3 enter the following: =Num2Words(A2,"pounds","pence")
Cell A3 should now show the value of A2 in words.
You can enter any number in Cell A2 up to 999,999,999,999.
Positive or negative is ignored, this will convert the absolute value.
You can change the pounds and pence arguments to your locale, e.g. dollars and cents, euros and cents, guineas and groats etc etc.
Use a plural for the larger unit (eg pounds not pound). The s will be trimmed if necessary. (this does not apply for the small unit, this always appears 'as is')

Sample File:

Num2Words.zip 22.32KB

Approved by mdmackillop

This entry has been viewed 72 times.